home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istan / ANLIB6.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  104.5 KB  |  2,556 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.3
  3. C---------------------------------------------------------
  4. C---------------------------------------------------------
  5. C    TOOLPACK/1    Release: 2.3
  6. C---------------------------------------------------------
  7. C ----------------------------------------------------------------------
  8. C
  9. C       T Y P E S   -   Find type of current statement beginning at the
  10. C                       specified token.
  11. C
  12.  
  13.         SUBROUTINE TYPES(ITOKA,ITYPEA,NTOKA,NTOK2A)
  14.         INTEGER ITOKA,ITYPEA,NTOKA,NTOK2A
  15.  
  16. C---------------------------------------------------------
  17. C    TOOLPACK/1    Release: 2.3
  18. C---------------------------------------------------------
  19.         COMMON/TOKENS/TOKTYP,TOKLEN,TXTPTR,TOKEN,NTOKSS,ISTTXT,ISTPTR,
  20.      +                MAXICH
  21.         INTEGER TOKTYP(800),TOKLEN(800),TXTPTR(800),
  22.      +          TOKEN,NTOKSS,ISTTXT(1322+800),ISTPTR(800),
  23.      +          MAXICH
  24.  
  25.         SAVE /TOKENS/
  26.  
  27. C
  28. C TOKTYP = array of token types for current statement
  29. C TOKLEN = parallel array of lengths of associated text strings
  30. C TXTPTR = parallel array of pointers into ISTMG character array of text
  31. C TOKEN = Current token number within statement being processed
  32. C NTOKSS = Number of tokens in statement
  33. C ISTTXT = IST text of token as read in before being converted by ZTOKTX
  34. C ISTPTR = parallel array (to TOKTYP) of pointers into ISTTXT
  35. C MAXICH = Last character used in ISTTXT array
  36. C
  37. C---------------------------------------------------------
  38. C    TOOLPACK/1    Release: 2.3
  39. C---------------------------------------------------------
  40. C                  CONTROL VARIABLES
  41.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  42.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  43.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  44.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  45.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  46.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  47.      *         NSTMG,       NTREEG,      NTYPEG
  48.  
  49.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  50.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  51.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  52.      +          NTREEG,NTYPEG
  53.  
  54.         SAVE /CNTRLC/
  55.  
  56. C---------------------------------------------------------
  57. C    TOOLPACK/1    Release: 2.3
  58. C---------------------------------------------------------
  59. C                  KEYWORD ID VARIABLES
  60.       COMMON / KEYSC   /    KAGOG,       KAIFG,       KASMTG,
  61.      *         KASSNG,      KBACKG,      KBIFG,       KBLOKG,
  62.      *         KCALLG,      KCFUNG,      KCGOG,       KCHARG,
  63.      *         KCLOSG,      KCMPXG,      KCOMNG,      KCONTG,
  64.      *         KDATAG,      KDBLEG,      KDFUNG,      KDIMNG,
  65.      *         KDOG,        KELSEG,      KELSFG,      KENDFG,
  66.      *         KENDG,       KENDIG,      KEQIVG,      KEXTLG,
  67.      *         KFORMG,      KIFUNG,      KIMPLG,      KINQRG,
  68.      *         KINSCG,      KINTEG,      KLFUNG,      KLIFG,
  69.      *         KLOGCG,      KNONEG,      KNTRYG,      KOPENG,
  70.      *         KPARAG,      KPAUSG,      KPRNTG,      KPROGG,
  71.      *         KREADG,      KREALG,      KRETNG,      KRFUNG,
  72.      *         KSAVEG,      KSFUNG,      KSTOPG,      KSUBRG,
  73.      *         KUFUNG,      KUGOG,       KWINDG,      KWRITG,
  74.      *         KXFUNG,      LASRTG,      LCMNTG,      LERRG,
  75.      *         LLINEG,      LSTMTG
  76.  
  77.         INTEGER KAGOG,KAIFG,KASMTG,KASSNG,KBACKG,KBIFG,KBLOKG,KCALLG,
  78.      +          KCFUNG,KCGOG,KCHARG,KCLOSG,KCMPXG,KCOMNG,KCONTG,KDATAG,
  79.      +          KDBLEG,KDFUNG,KDIMNG,KDOG,KELSEG,KELSFG,KENDFG,KENDG,
  80.      +          KENDIG,KEQIVG,KEXTLG,KFORMG,KIFUNG,KIMPLG,KINQRG,KINSCG,
  81.      +          KINTEG,KLFUNG,KLIFG,KLOGCG,KNONEG,KNTRYG,KOPENG,KPARAG,
  82.      +          KPAUSG,KPRNTG,KPROGG,KREADG,KREALG,KRETNG,KRFUNG,KSAVEG,
  83.      +          KSFUNG,KSTOPG,KSUNRG,KUUNG,KUGOG,KWINDG,KWRITG,KXFUNG,
  84.      +          LASRTG,LCMNTG,LERRG,LLINEG,LSTMTG
  85.         INTEGER KUFUNG,KSUBRG
  86.  
  87.         SAVE /KEYSC/
  88.  
  89. C---------------------------------------------------------
  90. C    TOOLPACK/1    Release: 2.3
  91. C---------------------------------------------------------
  92. C                  MAIN INTEGER STORAGE ARRAYS
  93. C MAXLBG = Maximum number of DO statement labels per routine
  94.         INTEGER MAXLBG
  95.         PARAMETER(MAXLBG=100)
  96.         COMMON / WORKC   /  IABEG(201),  ICRTNG(200), IPCNTG(75),
  97.      *         IRCNTG(75),  ISBEG(201),  ISCNTG(75),  INSTG(250),
  98.      *         KEXECG(75),  LABG(2,MAXLBG), KTOKG(81)
  99.         INTEGER IABEG,ICRTNG,IPCNTG,IRCNTG,ISBEG,ISCNTG,INSTG,
  100.      +          KEXECG,LABG,KTOKG
  101.         SAVE /WORKC/
  102. C---------------------------------------------------------
  103. C    TOOLPACK/1    Release: 2.4
  104. C---------------------------------------------------------
  105. C
  106. C  TKLAST = LAST TOKEN NUMBER
  107. C
  108.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  109.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  110.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  111.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  112.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  113.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  114.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  115.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  116.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  117.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  118.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  119.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  120.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  121.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  122.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  123.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  124.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  125.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  126.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  127.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  128.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  129.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  130.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  131.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  132.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  133.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  134.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  135.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  136.  
  137.  
  138. *$AS$ (ITOKA.LE.2 .OR. ITYPEG.EQ.KLIFG)
  139.         ITYPEA=KNONEG
  140.         NTOKA=ITOKA
  141.         IF (ITOKA.EQ.1 .AND. TOKTYP(1).EQ.TDCNST) NTOKA=2
  142.         NTOK2A=NTOKSS
  143.         ITYPEA=KTOKG(TOKTYP(NTOKA))
  144.         NTOKA=NTOKA+1
  145. C Verify initially assigned type code
  146.         IF (ITYPEA.EQ.KCHARG .OR. ITYPEA.EQ.KINTEG .OR.
  147.      +      ITYPEA.EQ.KREALG .OR. ITYPEA.EQ.KDBLEG .OR.
  148.      +      ITYPEA.EQ.KLOGCG .OR. ITYPEA.EQ.KCMPXG) THEN
  149. C Check for typed functions
  150.             CALL VTYPES(ITYPEA,NTOKA)
  151.         ELSE IF (ITYPEA.EQ.KUGOG) THEN
  152. C Initial type = GOTO
  153.             CALL VGOS(ITYPEA,NTOKA)
  154.         ELSE IF (ITYPEA.EQ.KLIFG) THEN
  155. C Initial type = IF
  156.             CALL VIFS(ITYPEA,NTOKA,NTOK2A)
  157.         END IF
  158. C Check for statement functions
  159.         IF (ITYPEA.EQ.KASMTG .AND. ITOKA.LE.2)
  160.      +      CALL VASMTS(ITYPEA,NTOKA)
  161.  
  162.         END
  163. C ----------------------------------------------------------------------
  164. C
  165. C       V A S T M T S   -   Verify type of assignment statement
  166. C
  167.  
  168.         SUBROUTINE VASMTS(ITYPEA,NTOKA)
  169.         INTEGER ITYPEA,NTOKA
  170.  
  171. C---------------------------------------------------------
  172. C    TOOLPACK/1    Release: 2.3
  173. C---------------------------------------------------------
  174. C Dictionary
  175. C   MAXDDG = Maximum number of dimension names in dictionary
  176. C   MAXRDG = Maximum number of routine names in dictionary
  177.         INTEGER MAXDDG,MAXRDG
  178.         PARAMETER(MAXDDG=150,MAXRDG=250)
  179.         COMMON /ANDICT/ DDICTG,RDICTG
  180.         CHARACTER*6 DDICTG(MAXDDG),RDICTG(MAXRDG)
  181.         SAVE /ANDICT/
  182. C---------------------------------------------------------
  183. C    TOOLPACK/1    Release: 2.3
  184. C---------------------------------------------------------
  185. C                  CONTROL VARIABLES
  186.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  187.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  188.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  189.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  190.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  191.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  192.      *         NSTMG,       NTREEG,      NTYPEG
  193.  
  194.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  195.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  196.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  197.      +          NTREEG,NTYPEG
  198.  
  199.         SAVE /CNTRLC/
  200.  
  201. C---------------------------------------------------------
  202. C    TOOLPACK/1    Release: 2.3
  203. C---------------------------------------------------------
  204. C                  KEYWORD ID VARIABLES
  205.       COMMON / KEYSC   /    KAGOG,       KAIFG,       KASMTG,
  206.      *         KASSNG,      KBACKG,      KBIFG,       KBLOKG,
  207.      *         KCALLG,      KCFUNG,      KCGOG,       KCHARG,
  208.      *         KCLOSG,      KCMPXG,      KCOMNG,      KCONTG,
  209.      *         KDATAG,      KDBLEG,      KDFUNG,      KDIMNG,
  210.      *         KDOG,        KELSEG,      KELSFG,      KENDFG,
  211.      *         KENDG,       KENDIG,      KEQIVG,      KEXTLG,
  212.      *         KFORMG,      KIFUNG,      KIMPLG,      KINQRG,
  213.      *         KINSCG,      KINTEG,      KLFUNG,      KLIFG,
  214.      *         KLOGCG,      KNONEG,      KNTRYG,      KOPENG,
  215.      *         KPARAG,      KPAUSG,      KPRNTG,      KPROGG,
  216.      *         KREADG,      KREALG,      KRETNG,      KRFUNG,
  217.      *         KSAVEG,      KSFUNG,      KSTOPG,      KSUBRG,
  218.      *         KUFUNG,      KUGOG,       KWINDG,      KWRITG,
  219.      *         KXFUNG,      LASRTG,      LCMNTG,      LERRG,
  220.      *         LLINEG,      LSTMTG
  221.  
  222.         INTEGER KAGOG,KAIFG,KASMTG,KASSNG,KBACKG,KBIFG,KBLOKG,KCALLG,
  223.      +          KCFUNG,KCGOG,KCHARG,KCLOSG,KCMPXG,KCOMNG,KCONTG,KDATAG,
  224.      +          KDBLEG,KDFUNG,KDIMNG,KDOG,KELSEG,KELSFG,KENDFG,KENDG,
  225.      +          KENDIG,KEQIVG,KEXTLG,KFORMG,KIFUNG,KIMPLG,KINQRG,KINSCG,
  226.      +          KINTEG,KLFUNG,KLIFG,KLOGCG,KNONEG,KNTRYG,KOPENG,KPARAG,
  227.      +          KPAUSG,KPRNTG,KPROGG,KREADG,KREALG,KRETNG,KRFUNG,KSAVEG,
  228.      +          KSFUNG,KSTOPG,KSUNRG,KUUNG,KUGOG,KWINDG,KWRITG,KXFUNG,
  229.      +          LASRTG,LCMNTG,LERRG,LLINEG,LSTMTG
  230.         INTEGER KUFUNG,KSUBRG
  231.  
  232.         SAVE /KEYSC/
  233.  
  234. C---------------------------------------------------------
  235. C    TOOLPACK/1    Release: 2.3
  236. C---------------------------------------------------------
  237.         COMMON/TOKENS/TOKTYP,TOKLEN,TXTPTR,TOKEN,NTOKSS,ISTTXT,ISTPTR,
  238.      +                MAXICH
  239.         INTEGER TOKTYP(800),TOKLEN(800),TXTPTR(800),
  240.      +          TOKEN,NTOKSS,ISTTXT(1322+800),ISTPTR(800),
  241.      +          MAXICH
  242.  
  243.         SAVE /TOKENS/
  244.  
  245. C
  246. C TOKTYP = array of token types for current statement
  247. C TOKLEN = parallel array of lengths of associated text strings
  248. C TXTPTR = parallel array of pointers into ISTMG character array of text
  249. C TOKEN = Current token number within statement being processed
  250. C NTOKSS = Number of tokens in statement
  251. C ISTTXT = IST text of token as read in before being converted by ZTOKTX
  252. C ISTPTR = parallel array (to TOKTYP) of pointers into ISTTXT
  253. C MAXICH = Last character used in ISTTXT array
  254. C
  255. C---------------------------------------------------------
  256. C    TOOLPACK/1    Release: 2.4
  257. C---------------------------------------------------------
  258. C
  259. C  TKLAST = LAST TOKEN NUMBER
  260. C
  261.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  262.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  263.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  264.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  265.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  266.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  267.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  268.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  269.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  270.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  271.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  272.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  273.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  274.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  275.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  276.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  277.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  278.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  279.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  280.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  281.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  282.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  283.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  284.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  285.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  286.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  287.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  288.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  289.  
  290.  
  291.         INTEGER ITOK,LOCL
  292.         CHARACTER*6 NAMEL
  293.  
  294.         INTEGER NFINDF
  295.         CHARACTER*6 NAME
  296.  
  297. C Look for parenthetical group to left of '='
  298.         ITOK=NTOKA
  299.         IF (TOKTYP(ITOK).EQ.TLPARN) THEN
  300. C '(' found. Ensure not character substring expression.
  301.  100        ITOK=ITOK+1
  302.             IF (TOKTYP(ITOK).EQ.TCOLON) RETURN
  303.             IF (TOKTYP(ITOK).NE.TEQUAL) GOTO 100
  304. C Pick up variable/functionname to left of '='
  305.             NAMEL=NAME(NTOKA-1)
  306.             IF (NAMEL.NE.' ') THEN
  307.                 IF (NFINDF(NAMEL,DDICTG,NDDICG).EQ.0) THEN
  308. C This is a statement function
  309.                     ITYPEA = KSFUNG
  310. C Save function name to avoid later recognition of function use as
  311. C external function use.
  312.                     CALL NSAVES(NAMEL,DDICTG,NDDICG,MAXDDG,LOCL)
  313.                     IF (LOCL.EQ.0) CALL ERRORS(13)
  314.                 END IF
  315.             END IF
  316.         END IF
  317.  
  318.         END
  319. C ----------------------------------------------------------------------
  320. C
  321. C       V T Y P E S   -   Verify type of type statement (may be function
  322. C
  323.         SUBROUTINE VTYPES(ITYPEA,NTOKA)
  324.         INTEGER ITYPEA,NTOKA
  325.  
  326. C---------------------------------------------------------
  327. C    TOOLPACK/1    Release: 2.4
  328. C---------------------------------------------------------
  329. C
  330. C  TKLAST = LAST TOKEN NUMBER
  331. C
  332.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  333.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  334.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  335.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  336.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  337.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  338.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  339.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  340.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  341.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  342.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  343.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  344.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  345.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  346.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  347.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  348.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  349.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  350.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  351.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  352.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  353.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  354.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  355.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  356.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  357.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  358.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  359.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  360.  
  361. C---------------------------------------------------------
  362. C    TOOLPACK/1    Release: 2.3
  363. C---------------------------------------------------------
  364.         COMMON/TOKENS/TOKTYP,TOKLEN,TXTPTR,TOKEN,NTOKSS,ISTTXT,ISTPTR,
  365.      +                MAXICH
  366.         INTEGER TOKTYP(800),TOKLEN(800),TXTPTR(800),
  367.      +          TOKEN,NTOKSS,ISTTXT(1322+800),ISTPTR(800),
  368.      +          MAXICH
  369.  
  370.         SAVE /TOKENS/
  371.  
  372. C
  373. C TOKTYP = array of token types for current statement
  374. C TOKLEN = parallel array of lengths of associated text strings
  375. C TXTPTR = parallel array of pointers into ISTMG character array of text
  376. C TOKEN = Current token number within statement being processed
  377. C NTOKSS = Number of tokens in statement
  378. C ISTTXT = IST text of token as read in before being converted by ZTOKTX
  379. C ISTPTR = parallel array (to TOKTYP) of pointers into ISTTXT
  380. C MAXICH = Last character used in ISTTXT array
  381. C
  382. C---------------------------------------------------------
  383. C    TOOLPACK/1    Release: 2.3
  384. C---------------------------------------------------------
  385. C                  KEYWORD ID VARIABLES
  386.       COMMON / KEYSC   /    KAGOG,       KAIFG,       KASMTG,
  387.      *         KASSNG,      KBACKG,      KBIFG,       KBLOKG,
  388.      *         KCALLG,      KCFUNG,      KCGOG,       KCHARG,
  389.      *         KCLOSG,      KCMPXG,      KCOMNG,      KCONTG,
  390.      *         KDATAG,      KDBLEG,      KDFUNG,      KDIMNG,
  391.      *         KDOG,        KELSEG,      KELSFG,      KENDFG,
  392.      *         KENDG,       KENDIG,      KEQIVG,      KEXTLG,
  393.      *         KFORMG,      KIFUNG,      KIMPLG,      KINQRG,
  394.      *         KINSCG,      KINTEG,      KLFUNG,      KLIFG,
  395.      *         KLOGCG,      KNONEG,      KNTRYG,      KOPENG,
  396.      *         KPARAG,      KPAUSG,      KPRNTG,      KPROGG,
  397.      *         KREADG,      KREALG,      KRETNG,      KRFUNG,
  398.      *         KSAVEG,      KSFUNG,      KSTOPG,      KSUBRG,
  399.      *         KUFUNG,      KUGOG,       KWINDG,      KWRITG,
  400.      *         KXFUNG,      LASRTG,      LCMNTG,      LERRG,
  401.      *         LLINEG,      LSTMTG
  402.  
  403.         INTEGER KAGOG,KAIFG,KASMTG,KASSNG,KBACKG,KBIFG,KBLOKG,KCALLG,
  404.      +          KCFUNG,KCGOG,KCHARG,KCLOSG,KCMPXG,KCOMNG,KCONTG,KDATAG,
  405.      +          KDBLEG,KDFUNG,KDIMNG,KDOG,KELSEG,KELSFG,KENDFG,KENDG,
  406.      +          KENDIG,KEQIVG,KEXTLG,KFORMG,KIFUNG,KIMPLG,KINQRG,KINSCG,
  407.      +          KINTEG,KLFUNG,KLIFG,KLOGCG,KNONEG,KNTRYG,KOPENG,KPARAG,
  408.      +          KPAUSG,KPRNTG,KPROGG,KREADG,KREALG,KRETNG,KRFUNG,KSAVEG,
  409.      +          KSFUNG,KSTOPG,KSUNRG,KUUNG,KUGOG,KWINDG,KWRITG,KXFUNG,
  410.      +          LASRTG,LCMNTG,LERRG,LLINEG,LSTMTG
  411.         INTEGER KUFUNG,KSUBRG
  412.  
  413.         SAVE /KEYSC/
  414.  
  415.  
  416.         INTEGER ITOK
  417.  
  418.         ITOK=NTOKA-1
  419.  100    ITOK=ITOK+1
  420.         IF (TOKTYP(ITOK).NE.TFUNCT .AND. ITOK.LT.NTOKSS) GOTO 100
  421.         IF (TOKTYP(ITOK).EQ.TFUNCT) THEN
  422.             IF (ITYPEA.EQ.KCHARG) ITYPEA=KCFUNG
  423.             IF (ITYPEA.EQ.KLOGCG) ITYPEA=KLFUNG
  424.             IF (ITYPEA.EQ.KREALG) ITYPEA=KRFUNG
  425.             IF (ITYPEA.EQ.KDBLEG) ITYPEA=KDFUNG
  426.             IF (ITYPEA.EQ.KINTEG) ITYPEA=KIFUNG
  427.             IF (ITYPEA.EQ.KCMPXG) ITYPEA=KXFUNG
  428.             NTOKA=ITOK+1
  429.         END IF
  430.  
  431.         END
  432. C ----------------------------------------------------------------------
  433. C
  434. C       V G O S   -   Verify type of GOTO statement
  435. C
  436.  
  437.         SUBROUTINE VGOS(ITYPEA,NTOKA)
  438.         INTEGER ITYPEA,NTOKA
  439.  
  440. C---------------------------------------------------------
  441. C    TOOLPACK/1    Release: 2.4
  442. C---------------------------------------------------------
  443. C
  444. C  TKLAST = LAST TOKEN NUMBER
  445. C
  446.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  447.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  448.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  449.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  450.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  451.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  452.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  453.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  454.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  455.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  456.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  457.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  458.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  459.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  460.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  461.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  462.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  463.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  464.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  465.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  466.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  467.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  468.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  469.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  470.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  471.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  472.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  473.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  474.  
  475. C---------------------------------------------------------
  476. C    TOOLPACK/1    Release: 2.3
  477. C---------------------------------------------------------
  478.         COMMON/TOKENS/TOKTYP,TOKLEN,TXTPTR,TOKEN,NTOKSS,ISTTXT,ISTPTR,
  479.      +                MAXICH
  480.         INTEGER TOKTYP(800),TOKLEN(800),TXTPTR(800),
  481.      +          TOKEN,NTOKSS,ISTTXT(1322+800),ISTPTR(800),
  482.      +          MAXICH
  483.  
  484.         SAVE /TOKENS/
  485.  
  486. C
  487. C TOKTYP = array of token types for current statement
  488. C TOKLEN = parallel array of lengths of associated text strings
  489. C TXTPTR = parallel array of pointers into ISTMG character array of text
  490. C TOKEN = Current token number within statement being processed
  491. C NTOKSS = Number of tokens in statement
  492. C ISTTXT = IST text of token as read in before being converted by ZTOKTX
  493. C ISTPTR = parallel array (to TOKTYP) of pointers into ISTTXT
  494. C MAXICH = Last character used in ISTTXT array
  495. C
  496. C---------------------------------------------------------
  497. C    TOOLPACK/1    Release: 2.3
  498. C---------------------------------------------------------
  499. C                  KEYWORD ID VARIABLES
  500.       COMMON / KEYSC   /    KAGOG,       KAIFG,       KASMTG,
  501.      *         KASSNG,      KBACKG,      KBIFG,       KBLOKG,
  502.      *         KCALLG,      KCFUNG,      KCGOG,       KCHARG,
  503.      *         KCLOSG,      KCMPXG,      KCOMNG,      KCONTG,
  504.      *         KDATAG,      KDBLEG,      KDFUNG,      KDIMNG,
  505.      *         KDOG,        KELSEG,      KELSFG,      KENDFG,
  506.      *         KENDG,       KENDIG,      KEQIVG,      KEXTLG,
  507.      *         KFORMG,      KIFUNG,      KIMPLG,      KINQRG,
  508.      *         KINSCG,      KINTEG,      KLFUNG,      KLIFG,
  509.      *         KLOGCG,      KNONEG,      KNTRYG,      KOPENG,
  510.      *         KPARAG,      KPAUSG,      KPRNTG,      KPROGG,
  511.      *         KREADG,      KREALG,      KRETNG,      KRFUNG,
  512.      *         KSAVEG,      KSFUNG,      KSTOPG,      KSUBRG,
  513.      *         KUFUNG,      KUGOG,       KWINDG,      KWRITG,
  514.      *         KXFUNG,      LASRTG,      LCMNTG,      LERRG,
  515.      *         LLINEG,      LSTMTG
  516.  
  517.         INTEGER KAGOG,KAIFG,KASMTG,KASSNG,KBACKG,KBIFG,KBLOKG,KCALLG,
  518.      +          KCFUNG,KCGOG,KCHARG,KCLOSG,KCMPXG,KCOMNG,KCONTG,KDATAG,
  519.      +          KDBLEG,KDFUNG,KDIMNG,KDOG,KELSEG,KELSFG,KENDFG,KENDG,
  520.      +          KENDIG,KEQIVG,KEXTLG,KFORMG,KIFUNG,KIMPLG,KINQRG,KINSCG,
  521.      +          KINTEG,KLFUNG,KLIFG,KLOGCG,KNONEG,KNTRYG,KOPENG,KPARAG,
  522.      +          KPAUSG,KPRNTG,KPROGG,KREADG,KREALG,KRETNG,KRFUNG,KSAVEG,
  523.      +          KSFUNG,KSTOPG,KSUNRG,KUUNG,KUGOG,KWINDG,KWRITG,KXFUNG,
  524.      +          LASRTG,LCMNTG,LERRG,LLINEG,LSTMTG
  525.         INTEGER KUFUNG,KSUBRG
  526.  
  527.         SAVE /KEYSC/
  528.  
  529.  
  530.         IF (TOKTYP(NTOKA).EQ.TLPARN) THEN
  531.             ITYPEA=KCGOG
  532.         ELSE IF (TOKTYP(NTOKA).EQ.TNAME) THEN
  533.             ITYPEA=KAGOG
  534.         ELSE
  535.             ITYPEA=KUGOG
  536.         END IF
  537.  
  538.         END
  539. C ----------------------------------------------------------------------
  540. C
  541. C       V I F S   -   Verify type of IF statement
  542. C
  543.  
  544.         SUBROUTINE VIFS(ITYPEA,NTOKA,NTOK2A)
  545.         INTEGER ITYPEA,NTOKA,NTOK2A
  546.  
  547. C---------------------------------------------------------
  548. C    TOOLPACK/1    Release: 2.4
  549. C---------------------------------------------------------
  550. C
  551. C  TKLAST = LAST TOKEN NUMBER
  552. C
  553.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  554.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  555.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  556.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  557.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  558.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  559.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  560.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  561.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  562.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  563.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  564.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  565.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  566.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  567.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  568.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  569.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  570.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  571.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  572.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  573.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  574.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  575.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  576.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  577.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  578.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  579.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  580.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  581.  
  582. C---------------------------------------------------------
  583. C    TOOLPACK/1    Release: 2.3
  584. C---------------------------------------------------------
  585.         COMMON/TOKENS/TOKTYP,TOKLEN,TXTPTR,TOKEN,NTOKSS,ISTTXT,ISTPTR,
  586.      +                MAXICH
  587.         INTEGER TOKTYP(800),TOKLEN(800),TXTPTR(800),
  588.      +          TOKEN,NTOKSS,ISTTXT(1322+800),ISTPTR(800),
  589.      +          MAXICH
  590.  
  591.         SAVE /TOKENS/
  592.  
  593. C
  594. C TOKTYP = array of token types for current statement
  595. C TOKLEN = parallel array of lengths of associated text strings
  596. C TXTPTR = parallel array of pointers into ISTMG character array of text
  597. C TOKEN = Current token number within statement being processed
  598. C NTOKSS = Number of tokens in statement
  599. C ISTTXT = IST text of token as read in before being converted by ZTOKTX
  600. C ISTPTR = parallel array (to TOKTYP) of pointers into ISTTXT
  601. C MAXICH = Last character used in ISTTXT array
  602. C
  603. C---------------------------------------------------------
  604. C    TOOLPACK/1    Release: 2.3
  605. C---------------------------------------------------------
  606. C                  KEYWORD ID VARIABLES
  607.       COMMON / KEYSC   /    KAGOG,       KAIFG,       KASMTG,
  608.      *         KASSNG,      KBACKG,      KBIFG,       KBLOKG,
  609.      *         KCALLG,      KCFUNG,      KCGOG,       KCHARG,
  610.      *         KCLOSG,      KCMPXG,      KCOMNG,      KCONTG,
  611.      *         KDATAG,      KDBLEG,      KDFUNG,      KDIMNG,
  612.      *         KDOG,        KELSEG,      KELSFG,      KENDFG,
  613.      *         KENDG,       KENDIG,      KEQIVG,      KEXTLG,
  614.      *         KFORMG,      KIFUNG,      KIMPLG,      KINQRG,
  615.      *         KINSCG,      KINTEG,      KLFUNG,      KLIFG,
  616.      *         KLOGCG,      KNONEG,      KNTRYG,      KOPENG,
  617.      *         KPARAG,      KPAUSG,      KPRNTG,      KPROGG,
  618.      *         KREADG,      KREALG,      KRETNG,      KRFUNG,
  619.      *         KSAVEG,      KSFUNG,      KSTOPG,      KSUBRG,
  620.      *         KUFUNG,      KUGOG,       KWINDG,      KWRITG,
  621.      *         KXFUNG,      LASRTG,      LCMNTG,      LERRG,
  622.      *         LLINEG,      LSTMTG
  623.  
  624.         INTEGER KAGOG,KAIFG,KASMTG,KASSNG,KBACKG,KBIFG,KBLOKG,KCALLG,
  625.      +          KCFUNG,KCGOG,KCHARG,KCLOSG,KCMPXG,KCOMNG,KCONTG,KDATAG,
  626.      +          KDBLEG,KDFUNG,KDIMNG,KDOG,KELSEG,KELSFG,KENDFG,KENDG,
  627.      +          KENDIG,KEQIVG,KEXTLG,KFORMG,KIFUNG,KIMPLG,KINQRG,KINSCG,
  628.      +          KINTEG,KLFUNG,KLIFG,KLOGCG,KNONEG,KNTRYG,KOPENG,KPARAG,
  629.      +          KPAUSG,KPRNTG,KPROGG,KREADG,KREALG,KRETNG,KRFUNG,KSAVEG,
  630.      +          KSFUNG,KSTOPG,KSUNRG,KUUNG,KUGOG,KWINDG,KWRITG,KXFUNG,
  631.      +          LASRTG,LCMNTG,LERRG,LLINEG,LSTMTG
  632.         INTEGER KUFUNG,KSUBRG
  633.  
  634.         SAVE /KEYSC/
  635.  
  636.  
  637.         INTEGER ITOK
  638.  
  639. C Balance parentheses
  640.         CALL BALPRT(NTOKA,ITOK)
  641.         IF (ITOK.GT.NTOKA .AND. ITOK.LT.NTOKSS) THEN
  642.             NTOK2A=ITOK
  643.             IF (TOKTYP(ITOK+1).EQ.TTHEN) THEN
  644.                 ITYPEA=KBIFG
  645.             ELSE IF (TOKTYP(ITOK+1).EQ.TDCNST) THEN
  646.                 ITYPEA=KAIFG
  647.             ELSE
  648.                 ITYPEA=KLIFG
  649.             END IF
  650.         ELSE
  651. C Parentheses unbalanced
  652.             CALL ERRORS(12)
  653.             ITYPEA=KNONEG
  654.         END IF
  655.  
  656.         END
  657. C ----------------------------------------------------------------------
  658. C
  659. C       W A R T H S   -   Insert arithmetic-IF function instrumentation
  660. C
  661.  
  662.         SUBROUTINE WARTHS
  663.  
  664. C---------------------------------------------------------
  665. C    TOOLPACK/1    Release: 2.3
  666. C---------------------------------------------------------
  667. C                  LOGICAL VARIABLES
  668.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  669.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  670.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  671.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  672.      *         TREEG
  673.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  674.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  675.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  676.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  677.  
  678.         SAVE /LOGIC/
  679.  
  680. C---------------------------------------------------------
  681. C    TOOLPACK/1    Release: 2.3
  682. C---------------------------------------------------------
  683.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  684.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  685.  
  686.         SAVE /IO/
  687.  
  688. C---------------------------------------------------------
  689. C    TOOLPACK/1    Release: 2.3
  690. C---------------------------------------------------------
  691.         COMMON/ANVNAM/VNAMEG
  692.         CHARACTER*5 VNAMEG
  693.         SAVE/ANVNAM/
  694.  
  695.         EXTERNAL ZMESS
  696.  
  697. *$AS$ (ARITHG)
  698.         CALL ZMESS('      DOUBLE PRECISION FUNCTION A'//VNAMEG//
  699.      +              '(DVALUE,ISEG)',IODINS)
  700.         IF (.NOT.TRACEG) CALL WCOMNS
  701.         CALL ZMESS('      DOUBLE PRECISION DVALUE',IODINS)
  702.         CALL ZMESS('      INTEGER ISEG',IODINS)
  703.         CALL ZMESS('      IF (DVALUE) 100,110,120',IODINS)
  704.         IF (TRACEG) THEN
  705.             CALL ZMESS(' 100  CALL T'//VNAMEG//'(ISEG)',IODINS)
  706.         ELSE
  707.             CALL ZMESS(' 100  I'//VNAMEG//'(ISEG)=I'//VNAMEG//
  708.      +                  '(ISEG)+1',IODINS)
  709.         END IF
  710.         CALL ZMESS('      GOTO 130',IODINS)
  711.         IF (TRACEG) THEN
  712.             CALL ZMESS(' 110  CALL T'//VNAMEG//'(ISEG+1)',IODINS)
  713.         ELSE
  714.             CALL ZMESS(' 110  I'//VNAMEG//'(ISEG+1)=I'//VNAMEG//
  715.      +                  '(ISEG+1)+1',IODINS)
  716.         END IF
  717.         CALL ZMESS('      GOTO 130',IODINS)
  718.         IF (TRACEG) THEN
  719.             CALL ZMESS(' 120  CALL T'//VNAMEG//'(ISEG+2)',IODINS)
  720.         ELSE
  721.             CALL ZMESS(' 120  I'//VNAMEG//'(ISEG+2)=I'//VNAMEG//
  722.      +                  '(ISEG+2)+1',IODINS)
  723.         END IF
  724.         CALL ZMESS(' 130  A'//VNAMEG//'=DVALUE',IODINS)
  725.         CALL ZMESS('      END',IODINS)
  726.  
  727.         END
  728. C ----------------------------------------------------------------------
  729. C
  730. C       W A S R T S   -   Insert assertion monitoring routine
  731. C                         instrumentation
  732. C
  733.  
  734.         SUBROUTINE WASRTS
  735.  
  736. C---------------------------------------------------------
  737. C    TOOLPACK/1    Release: 2.3
  738. C---------------------------------------------------------
  739. C                  LOGICAL VARIABLES
  740.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  741.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  742.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  743.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  744.      *         TREEG
  745.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  746.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  747.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  748.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  749.  
  750.         SAVE /LOGIC/
  751.  
  752. C---------------------------------------------------------
  753. C    TOOLPACK/1    Release: 2.3
  754. C---------------------------------------------------------
  755.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  756.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  757.  
  758.         SAVE /IO/
  759.  
  760. C---------------------------------------------------------
  761. C    TOOLPACK/1    Release: 2.3
  762. C---------------------------------------------------------
  763.         COMMON/ANVNAM/VNAMEG
  764.         CHARACTER*5 VNAMEG
  765.         SAVE/ANVNAM/
  766.  
  767.         EXTERNAL ZMESS
  768.  
  769. *$AS$ (ASSRTG)
  770.         CALL ZMESS('      SUBROUTINE M'//VNAMEG//'(LVALUE,NUMBER)',
  771.      +              IODINS)
  772.         CALL WCOMNS
  773.         CALL ZMESS('      LOGICAL LVALUE',IODINS)
  774.         CALL ZMESS('      INTEGER NUMBER',IODINS)
  775.         CALL ZMESS('      IF(..NOT..LVALUE) J'//VNAMEG//'(NUMBER)=J'//
  776.      +              VNAMEG//'(NUMBER)+1',IODINS)
  777.         CALL ZMESS('      END',IODINS)
  778.  
  779.         END
  780. C ----------------------------------------------------------------------
  781. C
  782. C       W B L O K S   -   Insert BLOCK DATA instrumentation
  783. C
  784.  
  785.         SUBROUTINE WBLOKS
  786.  
  787. C---------------------------------------------------------
  788. C    TOOLPACK/1    Release: 2.3
  789. C---------------------------------------------------------
  790. C                  LOGICAL VARIABLES
  791.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  792.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  793.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  794.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  795.      *         TREEG
  796.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  797.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  798.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  799.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  800.  
  801.         SAVE /LOGIC/
  802.  
  803. C---------------------------------------------------------
  804. C    TOOLPACK/1    Release: 2.3
  805. C---------------------------------------------------------
  806. C                  CONTROL VARIABLES
  807.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  808.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  809.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  810.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  811.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  812.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  813.      *         NSTMG,       NTREEG,      NTYPEG
  814.  
  815.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  816.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  817.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  818.      +          NTREEG,NTYPEG
  819.  
  820.         SAVE /CNTRLC/
  821.  
  822. C---------------------------------------------------------
  823. C    TOOLPACK/1    Release: 2.3
  824. C---------------------------------------------------------
  825.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  826.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  827.  
  828.         SAVE /IO/
  829.  
  830. C---------------------------------------------------------
  831. C    TOOLPACK/1    Release: 2.3
  832. C---------------------------------------------------------
  833.         COMMON/ANVNAM/VNAMEG
  834.         CHARACTER*5 VNAMEG
  835.         SAVE/ANVNAM/
  836.  
  837.         EXTERNAL ZMESS,ZCHOUT,ZPTINT
  838.  
  839.         CALL ZMESS('      BLOCK DATA B'//VNAMEG,IODINS)
  840.         CALL WCOMNS
  841.         CALL ZCHOUT('      DATA I'//VNAMEG//'/',IODINS)
  842.         CALL ZPTINT(NMSEG,1,IODINS)
  843.         CALL ZMESS('*0/',IODINS)
  844.         IF (ASSRTG) THEN
  845.             CALL ZCHOUT('      DATA J'//VNAMEG//'/',IODINS)
  846.             CALL ZPTINT(NMASRG,1,IODINS)
  847.             CALL ZMESS('*0/',IODINS)
  848.         END IF
  849.         IF (ENTRYG) CALL ZMESS('      DATA N'//VNAMEG//'/0/',IODINS)
  850.         CALL ZMESS('      END',IODINS)
  851.  
  852.         END
  853. C ----------------------------------------------------------------------
  854. C
  855. C       W C O M N S   -   Insert COMMON block instrumentation
  856. C
  857.  
  858.         SUBROUTINE WCOMNS
  859.  
  860. C---------------------------------------------------------
  861. C    TOOLPACK/1    Release: 2.3
  862. C---------------------------------------------------------
  863. C                  CONTROL VARIABLES
  864.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  865.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  866.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  867.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  868.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  869.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  870.      *         NSTMG,       NTREEG,      NTYPEG
  871.  
  872.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  873.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  874.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  875.      +          NTREEG,NTYPEG
  876.  
  877.         SAVE /CNTRLC/
  878.  
  879. C---------------------------------------------------------
  880. C    TOOLPACK/1    Release: 2.3
  881. C---------------------------------------------------------
  882. C                  LOGICAL VARIABLES
  883.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  884.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  885.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  886.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  887.      *         TREEG
  888.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  889.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  890.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  891.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  892.  
  893.         SAVE /LOGIC/
  894.  
  895. C---------------------------------------------------------
  896. C    TOOLPACK/1    Release: 2.3
  897. C---------------------------------------------------------
  898.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  899.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  900.  
  901.         SAVE /IO/
  902.  
  903. C---------------------------------------------------------
  904. C    TOOLPACK/1    Release: 2.3
  905. C---------------------------------------------------------
  906.         COMMON/ANVNAM/VNAMEG
  907.         CHARACTER*5 VNAMEG
  908.         SAVE/ANVNAM/
  909.  
  910.         EXTERNAL ZMESS,ZCHOUT,ZPTINT
  911.  
  912.         IF (ASSRTG) THEN
  913.             IF (ENTRYG) THEN
  914. C Segment and assertion arrays and entry flag
  915.                 CALL ZCHOUT('      COMMON /C'//VNAMEG//'/I'//VNAMEG//
  916.      +                  '(',IODINS)
  917.                 CALL ZPTINT(NMSEG,1,IODINS)
  918.                 CALL ZCHOUT('),J(',IODINS)
  919.                 CALL ZPTINT(NMASRG,1,IODINS)
  920.                 CALL ZMESS('),N'//VNAMEG,IODINS)
  921.                 CALL ZMESS('      INTEGER I'//VNAMEG//',J'//VNAMEG//
  922.      +                  ',N'//VNAMEG,IODINS)
  923.             ELSE
  924. C Segment and assertion arrays
  925.                 CALL ZCHOUT('      COMMON/C'//VNAMEG//'/I'//VNAMEG//'(',
  926.      +                     IODINS)
  927.                 CALL ZPTINT(NMSEG,1,IODINS)
  928.                 CALL ZCHOUT('),J'//VNAMEG//'(',IODINS)
  929.                 CALL ZPTINT(NMASRG,1,IODINS)
  930.                 CALL ZMESS(')',IODINS)
  931.                 CALL ZMESS('      INTEGER I'//VNAMEG//',J'//VNAMEG,
  932.      +                      IODINS)
  933.             END IF
  934.         ELSE
  935.             IF (ENTRYG) THEN
  936. C Segment array and entry flag
  937.                 CALL ZMESS('      COMMON/C'//VNAMEG//'/I'//VNAMEG//',N'
  938.      +                      //VNAMEG,IODINS)
  939.                 CALL ZCHOUT('      INTEGER I'//VNAMEG//'(',IODINS)
  940.                 CALL ZPTINT(NMSEG,1,IODINS)
  941.                 CALL ZMESS('),N'//VNAMEG,IODINS)
  942.             ELSE
  943. C Segment array
  944.                 CALL ZMESS('      COMMON/C'//VNAMEG//'/I'//VNAMEG,
  945.      +                      IODINS)
  946.                 CALL ZCHOUT('      INTEGER I'//VNAMEG//'(',IODINS)
  947.                 CALL ZPTINT(NMSEG,1,IODINS)
  948.                 CALL ZMESS(')',IODINS)
  949.             END IF
  950.         END IF
  951. C Save common block
  952.         CALL ZMESS('      SAVE /C'//VNAMEG//'/',IODINS)
  953.  
  954.         END
  955. C ----------------------------------------------------------------------
  956. C
  957. C       W F N   -   Write filename declaration to instrumented program
  958. C
  959.  
  960.         SUBROUTINE WFN2(FN,NAME,FN2,NAME2)
  961.         CHARACTER*6 NAME,NAME2
  962.         CHARACTER*(*) FN,FN2
  963.  
  964.         INTEGER FLEN,FLEN2
  965.         LOGICAL TWO
  966.  
  967.         TWO=.TRUE.
  968.         GOTO 100
  969.  
  970.         ENTRY WFN(FN,NAME)
  971.         TWO=.FALSE.
  972.  
  973.  100    CALL WFNA(FN,NAME,FLEN)
  974.         IF (TWO) CALL WFNA(FN2,NAME2,FLEN2)
  975.         CALL WFNB(FN,NAME,FLEN)
  976.         IF (TWO) CALL WFNB(FN2,NAME2,FLEN2)
  977.  
  978.         END
  979. C ----------------------------------------------------------------------
  980. C
  981. C       W F N A   -   Output filename declaration part A
  982. C
  983.  
  984.         SUBROUTINE WFNA(FN,NAME,FLEN)
  985.         CHARACTER*6 NAME
  986.         CHARACTER*(*) FN
  987.         INTEGER FLEN
  988.  
  989. C---------------------------------------------------------
  990. C    TOOLPACK/1    Release: 2.3
  991. C---------------------------------------------------------
  992.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  993.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  994.  
  995.         SAVE /IO/
  996.  
  997. C---------------------------------------------------------
  998. C    TOOLPACK/1    Release: 2.3
  999. C---------------------------------------------------------
  1000. C Option Settings
  1001.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  1002.      +                 MTREQG,TIEG,ITRUNG
  1003.  
  1004.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  1005.      +          ITRUNG
  1006.         LOGICAL TIEG
  1007.  
  1008.         SAVE /OPTSC/
  1009.  
  1010.  
  1011.         INTEGER STRIPL
  1012.  
  1013.         EXTERNAL ZCHOUT,ZMESS,ZPTINT
  1014.  
  1015.         IF (FN.NE.' ') THEN
  1016.             IF (FN.EQ.'''') THEN
  1017.                 FLEN=81
  1018.             ELSE
  1019.                 FLEN=STRIPL(FN)
  1020.             END IF
  1021.             IF (TIEG) THEN
  1022.                 CALL ZCHOUT('      INTEGER '//NAME//'(',IODINS)
  1023.                 CALL ZPTINT(FLEN+1,1,IODINS)
  1024.                 CALL ZMESS(')',IODINS)
  1025.             ELSE
  1026.                 CALL ZCHOUT('      CHARACTER*',IODINS)
  1027.                 CALL ZPTINT(FLEN,1,IODINS)
  1028.                 CALL ZMESS(NAME,IODINS)
  1029.             END IF
  1030.         END IF
  1031.  
  1032.         END
  1033. C ----------------------------------------------------------------------
  1034. C
  1035. C       W F N B   -   Output filename declaration part B
  1036. C
  1037.  
  1038.         SUBROUTINE WFNB(FN,NAME,FLEN)
  1039.         CHARACTER*6 NAME
  1040.         CHARACTER*(*) FN
  1041.         INTEGER FLEN
  1042.  
  1043. C---------------------------------------------------------
  1044. C    TOOLPACK/1    Release: 2.3
  1045. C---------------------------------------------------------
  1046.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1047.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1048.  
  1049.         SAVE /IO/
  1050.  
  1051. C---------------------------------------------------------
  1052. C    TOOLPACK/1    Release: 2.3
  1053. C---------------------------------------------------------
  1054. C Option Settings
  1055.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  1056.      +                 MTREQG,TIEG,ITRUNG
  1057.  
  1058.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  1059.      +          ITRUNG
  1060.         LOGICAL TIEG
  1061.  
  1062.         SAVE /OPTSC/
  1063.  
  1064.  
  1065.         CHARACTER X
  1066.         INTEGER IFN(134),I
  1067.  
  1068.         EXTERNAL ZCHOUT,ZPTINT,ZMESS
  1069.  
  1070.         IF (FN.NE.'''' .AND. FN.NE.' ') THEN
  1071.             IF (TIEG) THEN
  1072.                 CALL ZFTOI(FN,1,FLEN,IFN,.FALSE.)
  1073.                 DO 100 I=1,FLEN+1
  1074.                     CALL ZCHOUT('      DATA '//NAME//'(',IODINS)
  1075.                     CALL ZPTINT(I,1,IODINS)
  1076.                     CALL ZCHOUT(')/',IODINS)
  1077.                     CALL ZPTINT(IFN(I),1,IODINS)
  1078.                     CALL ZMESS('/',IODINS)
  1079.  100            CONTINUE
  1080.             ELSE
  1081.                 DO 200 I=1,FLEN
  1082.                     CALL ZCHOUT('      DATA '//NAME//'(',IODINS)
  1083.                     CALL ZPTINT(I,1,IODINS)
  1084.                     CALL ZCHOUT(':',IODINS)
  1085.                     CALL ZPTINT(I,1,IODINS)
  1086.                     X=FN(I:I)
  1087.                     CALL OUTMSG(')/'''//X//'''/',IODINS)
  1088.  200            CONTINUE
  1089.             END IF
  1090.         END IF
  1091.  
  1092.         END
  1093. C ----------------------------------------------------------------------
  1094. C
  1095. C       W G O T O S   -   Insert computed GOTO function instrumentation
  1096. C
  1097.  
  1098.         SUBROUTINE WGOTOS
  1099.  
  1100. C---------------------------------------------------------
  1101. C    TOOLPACK/1    Release: 2.3
  1102. C---------------------------------------------------------
  1103. C                  LOGICAL VARIABLES
  1104.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  1105.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  1106.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  1107.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  1108.      *         TREEG
  1109.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  1110.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  1111.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  1112.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  1113.  
  1114.         SAVE /LOGIC/
  1115.  
  1116. C---------------------------------------------------------
  1117. C    TOOLPACK/1    Release: 2.3
  1118. C---------------------------------------------------------
  1119.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1120.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1121.  
  1122.         SAVE /IO/
  1123.  
  1124. C---------------------------------------------------------
  1125. C    TOOLPACK/1    Release: 2.3
  1126. C---------------------------------------------------------
  1127.         COMMON/ANVNAM/VNAMEG
  1128.         CHARACTER*5 VNAMEG
  1129.         SAVE/ANVNAM/
  1130.  
  1131.         EXTERNAL ZMESS
  1132.  
  1133. *$AS$ (CGOTOG)
  1134.         CALL ZMESS('      INTEGER FUNCTION K'//VNAMEG//
  1135.      +              '(IVALUE,ISEG,NUMARG)',IODINS)
  1136.         CALL ZMESS('      INTEGER IVALUE,ISEG,NUMARG',IODINS)
  1137.         IF (.NOT.TRACEG) CALL WCOMNS
  1138.         CALL OUTMSG('      IF (IVALUE.GE.1 .AND. IVALUE.LE.NUMARG)',
  1139.      +              IODINS)
  1140.         IF (TRACEG) THEN
  1141.             CALL ZMESS('     *CALL T'//VNAMEG//'(ISEG+IVALUE)',IODINS)
  1142.         ELSE
  1143.             CALL ZMESS('     *I'//VNAMEG//'(ISEG+IVALUE)=I'//VNAMEG//
  1144.      +                  '(ISEG+IVALUE)+1',IODINS)
  1145.         END IF
  1146.         CALL ZMESS('      K'//VNAMEG//'=IVALUE',IODINS)
  1147.         CALL ZMESS('      END',IODINS)
  1148.  
  1149.         END
  1150. C ----------------------------------------------------------------------
  1151. C
  1152. C       W H I N S   -  Insert history file input routine instrumentation
  1153. C
  1154.  
  1155.         SUBROUTINE WHINS
  1156.  
  1157. C---------------------------------------------------------
  1158. C    TOOLPACK/1    Release: 2.3
  1159. C---------------------------------------------------------
  1160. C Filenames
  1161.         COMMON/ANFNAM/IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  1162.         CHARACTER*81 IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  1163.         SAVE /ANFNAM/
  1164. C---------------------------------------------------------
  1165. C    TOOLPACK/1    Release: 2.3
  1166. C---------------------------------------------------------
  1167. C                  LOGICAL VARIABLES
  1168.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  1169.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  1170.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  1171.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  1172.      *         TREEG
  1173.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  1174.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  1175.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  1176.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  1177.  
  1178.         SAVE /LOGIC/
  1179.  
  1180. C---------------------------------------------------------
  1181. C    TOOLPACK/1    Release: 2.3
  1182. C---------------------------------------------------------
  1183. C Option Settings
  1184.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  1185.      +                 MTREQG,TIEG,ITRUNG
  1186.  
  1187.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  1188.      +          ITRUNG
  1189.         LOGICAL TIEG
  1190.  
  1191.         SAVE /OPTSC/
  1192.  
  1193. C---------------------------------------------------------
  1194. C    TOOLPACK/1    Release: 2.3
  1195. C---------------------------------------------------------
  1196.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1197.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1198.  
  1199.         SAVE /IO/
  1200.  
  1201. C---------------------------------------------------------
  1202. C    TOOLPACK/1    Release: 2.3
  1203. C---------------------------------------------------------
  1204.         COMMON/ANVNAM/VNAMEG
  1205.         CHARACTER*5 VNAMEG
  1206.         SAVE/ANVNAM/
  1207.  
  1208.         EXTERNAL ZMESS
  1209.  
  1210. *$AS$ (HISTG)
  1211.         CALL ZMESS('      SUBROUTINE P'//VNAMEG//
  1212.      +              '(IARY,IDIM,IEOF,INHST,OPENED)',IODINS)
  1213.         CALL ZMESS('      INTEGER IDIM,IARY(IDIM),IHIST(16),I,INHST,'//
  1214.      +             'NUM,IEOF',IODINS)
  1215.         CALL ZMESS('      LOGICAL OPENED',IODINS)
  1216.         IF (TIEG) THEN
  1217.             CALL ZMESS('      INTEGER GETCH,CTOI,BUFF(134)',IODINS)
  1218.             CALL ZMESS('      INTEGER OPEN,CREATE,ZGTCMD',IODINS)
  1219.         END IF
  1220.         CALL WFN(IHSTFN,'IHSTFN')
  1221. C For assertion processing: don't open file if already open
  1222.         IF (ASSRTG) CALL ZMESS('      IF (OPENED) GOTO 99',IODINS)
  1223. C Ask for filename if required
  1224.         IF (IHSTFN.EQ.'''') THEN
  1225.             IF (TIEG) THEN
  1226.                 CALL ZMESS('      CALL ZMESS(''Enter history input '//
  1227.      +                      'filename:'',1)',IODINS)
  1228.                 CALL ZMESS('      JUNK=ZGTCMD(IHSTFN,0)',IODINS)
  1229.             ELSE
  1230.                 CALL ZMESS('      PRINT *,''Enter history input '//
  1231.      +                      'filename''',IODINS)
  1232.                 CALL ZMESS('      READ (*,23)IHSTFN',IODINS)
  1233.                 CALL ZMESS(' 23   FORMAT(A)',IODINS)
  1234.             END IF
  1235.         END IF
  1236.         CALL ZMESS('      IEOF=1',IODINS)
  1237.         IF (IHSTFN.NE.' ') THEN
  1238.             IF (TIEG) THEN
  1239.                 IF (INHSTG.EQ.ITHSTG .AND. OHSTFN.EQ.' ') THEN
  1240.                     CALL ZMESS('      INHST=OPEN(IHSTFN,2)',
  1241.      +                          IODINS)
  1242.                     CALL ZMESS('      IF (INHST..EQ..-1) THEN',IODINS)
  1243.                     CALL ZMESS('      INHST=CREATE(IHSTFN,'//
  1244.      +                          '2)',IODINS)
  1245.                     CALL ZMESS('      RETURN',IODINS)
  1246.                     CALL ZMESS('      END IF',IODINS)
  1247.                 ELSE
  1248.                     CALL ZMESS('      INHST=OPEN(IHSTFN,0)',IODINS)
  1249.                     CALL OUTMSG('      IF (INHST.EQ.-1) RETURN',IODINS)
  1250.                 END IF
  1251.             ELSE
  1252.                 IF (INHSTG.EQ.ITHSTG .AND. OHSTFN.EQ.' ') THEN
  1253.                     CALL ZMESS('      OPEN(INHST,FILE=IHSTFN,'//
  1254.      +                          'STATUS=''UNKNOWN'',ERR=130)',IODINS)
  1255.                 ELSE
  1256.                     CALL ZMESS('      OPEN(INHST,FILE=IHSTFN,'//
  1257.      +                          'STATUS=''OLD'',ERR=130)',IODINS)
  1258.                 END IF
  1259.                 CALL ZMESS('      REWIND(INHST,ERR=130)',IODINS)
  1260.             END IF
  1261.         END IF
  1262.         IF (TIEG) THEN
  1263.             CALL ZMESS('  99  JUNK=ZGTCMD(BUFF,INHST)',IODINS)
  1264.             CALL ZMESS('      JUNK=1',IODINS)
  1265.             CALL ZMESS('      IF (CTOI(BUFF,JUNK)..NE..IDIM)',IODINS)
  1266.             CALL ZMESS('     +CALL ERROR(''WRONG HISTORY FILE'')',
  1267.      +                  IODINS)
  1268.             CALL ZMESS('      NUM=0',IODINS)
  1269.             CALL ZMESS(' 100  DO 105 I=1,16',IODINS)
  1270.             CALL ZMESS('      CALL READF(BUFF,8,INHST)',IODINS)
  1271.             CALL ZMESS('      JUNK=1',IODINS)
  1272.             CALL ZMESS('      IHIST(I)=CTOI(BUFF,JUNK)',IODINS)
  1273.             CALL ZMESS(' 105  CONTINUE',IODINS)
  1274.             CALL ZMESS('      JUNK=GETCH(JUNK,INHST)',IODINS)
  1275.         ELSE
  1276.             CALL ZMESS('  99  READ(INHST,9010,END=130,ERR=130) NUM',
  1277.      +                  IODINS)
  1278.             CALL ZMESS('      IF(NUM..NE..IDIM)THEN',IODINS)
  1279.             CALL ZMESS('      PRINT *,''WRONG HISTORY FILE''',IODINS)
  1280.             CALL ZMESS('      STOP ''ERROR ABORT''',IODINS)
  1281.             CALL ZMESS('      END IF',IODINS)
  1282.             CALL ZMESS('      NUM=0',IODINS)
  1283.             CALL ZMESS(' 100  READ(INHST,9010,END=130,ERR=130) IHIST',
  1284.      +                  IODINS)
  1285.         END IF
  1286.         CALL ZMESS('      DO 110 I=1,16',IODINS)
  1287.         CALL ZMESS('      NUM=NUM+1',IODINS)
  1288.         CALL ZMESS('      IF (NUM..GT..IDIM) GOTO 120',IODINS)
  1289.         CALL ZMESS(' 110  IARY(NUM)=IARY(NUM)+IHIST(I)',IODINS)
  1290.         CALL ZMESS('      IF (NUM..LT..IDIM) GOTO 100',IODINS)
  1291.         CALL ZMESS(' 120  IEOF=0',IODINS)
  1292.         CALL ZMESS(' 130  CONTINUE',IODINS)
  1293.         IF (.NOT.TIEG) THEN
  1294.             CALL ZMESS(' 9000 FORMAT(I8)',IODINS)
  1295.             CALL ZMESS(' 9010 FORMAT(16I8)',IODINS)
  1296.         END IF
  1297.         CALL ZMESS('      END',IODINS)
  1298.  
  1299.         END
  1300. C ----------------------------------------------------------------------
  1301. C
  1302. C       W H O U T S   -   INSERT HISTORY FILE OUTPUT ROUTINE
  1303. C                         INSTRUMENTATION
  1304. C
  1305.  
  1306.         SUBROUTINE WHOUTS
  1307.  
  1308. C---------------------------------------------------------
  1309. C    TOOLPACK/1    Release: 2.3
  1310. C---------------------------------------------------------
  1311. C Filenames
  1312.         COMMON/ANFNAM/IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  1313.         CHARACTER*81 IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  1314.         SAVE /ANFNAM/
  1315. C---------------------------------------------------------
  1316. C    TOOLPACK/1    Release: 2.3
  1317. C---------------------------------------------------------
  1318. C                  LOGICAL VARIABLES
  1319.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  1320.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  1321.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  1322.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  1323.      *         TREEG
  1324.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  1325.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  1326.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  1327.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  1328.  
  1329.         SAVE /LOGIC/
  1330.  
  1331. C---------------------------------------------------------
  1332. C    TOOLPACK/1    Release: 2.3
  1333. C---------------------------------------------------------
  1334. C Option Settings
  1335.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  1336.      +                 MTREQG,TIEG,ITRUNG
  1337.  
  1338.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  1339.      +          ITRUNG
  1340.         LOGICAL TIEG
  1341.  
  1342.         SAVE /OPTSC/
  1343.  
  1344. C---------------------------------------------------------
  1345. C    TOOLPACK/1    Release: 2.3
  1346. C---------------------------------------------------------
  1347.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1348.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1349.  
  1350.         SAVE /IO/
  1351.  
  1352. C---------------------------------------------------------
  1353. C    TOOLPACK/1    Release: 2.3
  1354. C---------------------------------------------------------
  1355.         COMMON/ANVNAM/VNAMEG
  1356.         CHARACTER*5 VNAMEG
  1357.         SAVE/ANVNAM/
  1358.  
  1359.         LOGICAL RUNF
  1360.  
  1361.         CALL ZMESS('      SUBROUTINE O'//VNAMEG//
  1362.      +              '(IARY,IDIM,ITHST,RUNF)',IODINS)
  1363.         CALL ZMESS('      INTEGER IDIM,IARY(IDIM),IHIST(16),ITHST,'//
  1364.      +             'NUM,I,L',IODINS)
  1365.         CALL ZMESS('      LOGICAL FTF,RUNF',IODINS)
  1366.         CALL ZMESS('      SAVE',IODINS)
  1367.         IF (TIEG) THEN
  1368.             CALL ZMESS('      CHARACTER*128 LINE',IODINS)
  1369.             CALL ZMESS('      INTEGER OPEN,CREATE,ZGTCMD',IODINS)
  1370.         END IF
  1371.         RUNF=(ITRUNG.NE.0 .OR. RUNFN.NE.' ')
  1372. *$AS$ (HISTG .OR. RUNF)
  1373.         IF (RUNF) THEN
  1374.             CALL ZMESS('      LOGICAL RUNFTF',IODINS)
  1375.             IF (HISTG) THEN
  1376.                 CALL WFN2(OHSTFN,'OHSTFN',RUNFN,'RUNFN ')
  1377.             ELSE
  1378.                 CALL WFN(RUNFN,'RUNFN ')
  1379.             END IF
  1380.             CALL ZMESS('      DATA RUNFTF/..TRUE../',IODINS)
  1381.         ELSE
  1382.             CALL WFN(OHSTFN,'OHSTFN')
  1383.         END IF
  1384.         CALL ZMESS('      DATA FTF/..TRUE../',IODINS)
  1385.         IF (RUNF) THEN
  1386.             CALL ZMESS('      IF (RUNF ..AND.. RUNFTF) THEN',IODINS)
  1387.             IF (RUNFN.EQ.'''') THEN
  1388.                 IF (TIEG) THEN
  1389.                     CALL ZMESS('      CALL ZMESS(''Enter run data '//
  1390.      +                          'filename:'',1)',IODINS)
  1391.                     CALL ZMESS('      JUNK=ZGTCMD(RUNFN,0)',IODINS)
  1392.                 ELSE
  1393.                     CALL ZMESS('      PRINT *,''Enter run data '//
  1394.      +                          'filename''',IODINS)
  1395.                     CALL ZMESS('      READ (*,23) RUNFN',IODINS)
  1396.                     CALL ZMESS(' 23   FORMAT(A)',IODINS)
  1397.                 END IF
  1398.             END IF
  1399.             IF (TIEG .AND. RUNFN.NE.' ') THEN
  1400.                 CALL ZMESS('      ITHST=CREATE(RUNFN,1)',IODINS)
  1401.                 CALL ZMESS('      IF (ITHST..EQ..-1) RETURN',IODINS)
  1402.             ELSE IF (RUNFN.NE.' ') THEN
  1403.                 CALL ZMESS('      OPEN(ITHST,FILE=RUNFN,STATUS='''//
  1404.      +                      'UNKNOWN'',ERR=140)',IODINS)
  1405.                 CALL ZMESS('      REWIND(ITHST,ERR=16)',IODINS)
  1406.                 CALL ZMESS('   16 CONTINUE',IODINS)
  1407.             END IF
  1408.             CALL ZMESS('      RUNFTF=..FALSE..',IODINS)
  1409.             CALL ZMESS('      END IF',IODINS)
  1410.         END IF
  1411.         CALL ZMESS('      IF (FTF ..AND.. ..NOT..RUNF) THEN',IODINS)
  1412.         IF (OHSTFN.EQ.'''') THEN
  1413.             IF (TIEG) THEN
  1414.                 CALL ZMESS('      CALL ZMESS(''Enter history output '//
  1415.      +                     'filename:'',1)',IODINS)
  1416.                 CALL ZMESS('      JUNK=ZGTCMD(OHSTFN,0)',IODINS)
  1417.             ELSE
  1418.                 CALL ZMESS('      PRINT *,''Enter history output '//
  1419.      +                     'filename''',IODINS)
  1420.                 CALL ZMESS('      READ (*,24) OHSTFN',IODINS)
  1421.                 CALL ZMESS(' 24   FORMAT(A)',IODINS)
  1422.             END IF
  1423.         END IF
  1424.         IF (HISTG .AND. OHSTFN.EQ.' ') THEN
  1425.             IF (TIEG) CALL ZMESS('      CALL SEEK(0,ITHST)',IODINS)
  1426.         ELSE IF (HISTG) THEN
  1427.             IF (TIEG) THEN
  1428.                 CALL ZMESS('      ITHST=CREATE(OHSTFN,1)',IODINS)
  1429.                 CALL ZMESS('      IF (ITHST..EQ..-1) RETURN',IODINS)
  1430.             ELSE
  1431.                 CALL ZMESS('      OPEN(ITHST,FILE=OHSTFN,STATUS='''//
  1432.      +                      'UNKNOWN'',ERR=140)',IODINS)
  1433.             END IF
  1434.         END IF
  1435.         IF (HISTG .AND..NOT. TIEG) THEN
  1436.             CALL ZMESS('      REWIND(ITHST,ERR=17)',IODINS)
  1437.             CALL ZMESS(' 17   CONTINUE',IODINS)
  1438.         END IF
  1439.         CALL ZMESS('      FTF=..FALSE..',IODINS)
  1440.         CALL ZMESS('      END IF',IODINS)
  1441.         CALL ZMESS('      NUM=0',IODINS)
  1442.         IF (TIEG) THEN
  1443.             CALL ZMESS('      CALL ZPTINT(IDIM,8,ITHST)',IODINS)
  1444.             CALL ZMESS('      CALL PUTCH(10,ITHST)',IODINS)
  1445.         ELSE
  1446.             CALL ZMESS('      WRITE(ITHST,9000)IDIM',IODINS)
  1447.         END IF
  1448.         CALL ZMESS('      DO 100 L=1,IDIM',IODINS)
  1449.         CALL ZMESS('      NUM=NUM+1',IODINS)
  1450.         CALL ZMESS('      IHIST(NUM)=IARY(L)',IODINS)
  1451.         CALL ZMESS('      IF (NUM..EQ..16..OR..L..EQ..IDIM)THEN',
  1452.      +              IODINS)
  1453.         IF (TIEG) THEN
  1454.             CALL ZMESS('      WRITE(LINE,9010) (IHIST(I),I=1,NUM)',
  1455.      +                  IODINS)
  1456.             CALL ZMESS('      CALL ZMESS(LINE,ITHST)',IODINS)
  1457.         ELSE
  1458.             CALL ZMESS('      WRITE(ITHST,9010) (IHIST(I),I=1,NUM)',
  1459.      +                  IODINS)
  1460.         END IF
  1461.         CALL ZMESS('      NUM=0',IODINS)
  1462.         CALL ZMESS('      ENDIF',IODINS)
  1463.         CALL ZMESS(' 100  CONTINUE',IODINS)
  1464.         CALL ZMESS(' 140  RETURN',IODINS)
  1465.         CALL ZMESS(' 9000 FORMAT(I8)',IODINS)
  1466.         CALL ZMESS(' 9010 FORMAT(16I8..8)',IODINS)
  1467.         CALL ZMESS('      END',IODINS)
  1468.  
  1469.         END
  1470. C ----------------------------------------------------------------------
  1471. C
  1472. C       W I F D O S   -   Insert logical function instrumentation
  1473. C
  1474.  
  1475.         SUBROUTINE WIFDOS
  1476.  
  1477. C---------------------------------------------------------
  1478. C    TOOLPACK/1    Release: 2.3
  1479. C---------------------------------------------------------
  1480. C                  LOGICAL VARIABLES
  1481.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  1482.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  1483.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  1484.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  1485.      *         TREEG
  1486.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  1487.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  1488.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  1489.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  1490.  
  1491.         SAVE /LOGIC/
  1492.  
  1493. C---------------------------------------------------------
  1494. C    TOOLPACK/1    Release: 2.3
  1495. C---------------------------------------------------------
  1496.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1497.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1498.  
  1499.         SAVE /IO/
  1500.  
  1501. C---------------------------------------------------------
  1502. C    TOOLPACK/1    Release: 2.3
  1503. C---------------------------------------------------------
  1504.         COMMON/ANVNAM/VNAMEG
  1505.         CHARACTER*5 VNAMEG
  1506.         SAVE/ANVNAM/
  1507.  
  1508.         EXTERNAL ZMESS
  1509.  
  1510. *$AS$ (IFDOG)
  1511.         CALL ZMESS('      LOGICAL FUNCTION L'//VNAMEG//
  1512.      +              '(LVALUE,ISEG,JSEG)',IODINS)
  1513.         CALL ZMESS('      LOGICAL LVALUE',IODINS)
  1514.         CALL ZMESS('      INTEGER ISEG,JSEG',IODINS)
  1515.         IF (.NOT.TRACEG) CALL WCOMNS
  1516.         CALL ZMESS('      IF (ISEG..NE..0)',IODINS)
  1517.         IF (TRACEG) THEN
  1518.             CALL ZMESS('     + CALL T'//VNAMEG//'(ISEG)',IODINS)
  1519.         ELSE
  1520.             CALL ZMESS('     + I'//VNAMEG//'(ISEG)=I'//VNAMEG//
  1521.      +                  '(ISEG)+1',IODINS)
  1522.         END IF
  1523.         CALL ZMESS('      IF (LVALUE..AND..JSEG..NE..0)',IODINS)
  1524.         IF (TRACEG) THEN
  1525.             CALL ZMESS('     + CALL T'//VNAMEG//'(JSEG)',IODINS)
  1526.         ELSE
  1527.             CALL ZMESS('     + I'//VNAMEG//'(JSEG)=I'//VNAMEG//
  1528.      +                  '(JSEG)+1',IODINS)
  1529.         END IF
  1530.         CALL ZMESS('      L'//VNAMEG//'=LVALUE',IODINS)
  1531.         CALL ZMESS('      RETURN',IODINS)
  1532.         CALL ZMESS('      END',IODINS)
  1533.  
  1534.         END
  1535. C ----------------------------------------------------------------------
  1536. C
  1537. C       W L I N E S   -   Insert line control routine instrumentation
  1538. C
  1539.  
  1540.         SUBROUTINE WLINES
  1541.  
  1542. C---------------------------------------------------------
  1543. C    TOOLPACK/1    Release: 2.3
  1544. C---------------------------------------------------------
  1545. C Option Settings
  1546.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  1547.      +                 MTREQG,TIEG,ITRUNG
  1548.  
  1549.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  1550.      +          ITRUNG
  1551.         LOGICAL TIEG
  1552.  
  1553.         SAVE /OPTSC/
  1554.  
  1555. C---------------------------------------------------------
  1556. C    TOOLPACK/1    Release: 2.3
  1557. C---------------------------------------------------------
  1558.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1559.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1560.  
  1561.         SAVE /IO/
  1562.  
  1563. C---------------------------------------------------------
  1564. C    TOOLPACK/1    Release: 2.3
  1565. C---------------------------------------------------------
  1566.         COMMON/ANVNAM/VNAMEG
  1567.         CHARACTER*5 VNAMEG
  1568.         SAVE/ANVNAM/
  1569.  
  1570.         EXTERNAL ZCHOUT,ZPTINT,ZMESS
  1571.  
  1572.         CALL ZMESS('      SUBROUTINE Q'//VNAMEG//'(LINE,ITLST)',IODINS)
  1573.         CALL ZMESS('      INTEGER LINE,ITLST,I',IODINS)
  1574.         CALL ZMESS('      LINE=LINE+1',IODINS)
  1575.         CALL ZCHOUT('      IF (LINE..GT..',IODINS)
  1576.         CALL ZPTINT(50,1,IODINS)
  1577.         CALL ZMESS(')THEN',IODINS)
  1578.         IF (TIEG) THEN
  1579.             CALL ZMESS('      CALL PUTCH(10,ITLST)',IODINS)
  1580.             CALL ZMESS('      CALL ZOBLNK(16,ITLST)',IODINS)
  1581.             CALL ZMESS('      CALL ZMESS(''0     1     2     3    ''//',
  1582.      +                  IODINS)
  1583.             CALL ZMESS('     +'' 4     5     6     7     8     9'','//
  1584.      +                  'ITLST)',IODINS)
  1585.         ELSE
  1586.             CALL ZMESS('      WRITE(ITLST,100) (I,I=1,9)',IODINS)
  1587.             CALL ZMESS(' 100  FORMAT(''1'',16X,''0'',9(5X,I1)/)',
  1588.      +                  IODINS)
  1589.         END IF
  1590.         CALL ZMESS('      LINE=5',IODINS)
  1591.         CALL ZMESS('      ENDIF',IODINS)
  1592.         CALL ZMESS('      END',IODINS)
  1593.  
  1594.         END
  1595. C ----------------------------------------------------------------------
  1596. C
  1597. C       W R A P S   -   Insert wrapup control routine instrumentation
  1598. C
  1599.  
  1600.         SUBROUTINE WRAPS
  1601.  
  1602. C---------------------------------------------------------
  1603. C    TOOLPACK/1    Release: 2.3
  1604. C---------------------------------------------------------
  1605. C Filenames
  1606.         COMMON/ANFNAM/IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  1607.         CHARACTER*81 IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  1608.         SAVE /ANFNAM/
  1609. C---------------------------------------------------------
  1610. C    TOOLPACK/1    Release: 2.3
  1611. C---------------------------------------------------------
  1612. C                  CONTROL VARIABLES
  1613.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  1614.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  1615.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  1616.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  1617.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  1618.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  1619.      *         NSTMG,       NTREEG,      NTYPEG
  1620.  
  1621.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  1622.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  1623.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  1624.      +          NTREEG,NTYPEG
  1625.  
  1626.         SAVE /CNTRLC/
  1627.  
  1628. C---------------------------------------------------------
  1629. C    TOOLPACK/1    Release: 2.3
  1630. C---------------------------------------------------------
  1631.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1632.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1633.  
  1634.         SAVE /IO/
  1635.  
  1636. C---------------------------------------------------------
  1637. C    TOOLPACK/1    Release: 2.3
  1638. C---------------------------------------------------------
  1639. C                  LOGICAL VARIABLES
  1640.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  1641.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  1642.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  1643.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  1644.      *         TREEG
  1645.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  1646.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  1647.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  1648.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  1649.  
  1650.         SAVE /LOGIC/
  1651.  
  1652. C---------------------------------------------------------
  1653. C    TOOLPACK/1    Release: 2.3
  1654. C---------------------------------------------------------
  1655. C Option Settings
  1656.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  1657.      +                 MTREQG,TIEG,ITRUNG
  1658.  
  1659.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  1660.      +          ITRUNG
  1661.         LOGICAL TIEG
  1662.  
  1663.         SAVE /OPTSC/
  1664.  
  1665. C---------------------------------------------------------
  1666. C    TOOLPACK/1    Release: 2.3
  1667. C---------------------------------------------------------
  1668.         COMMON/ANVNAM/VNAMEG
  1669.         CHARACTER*5 VNAMEG
  1670.         SAVE/ANVNAM/
  1671. C---------------------------------------------------------
  1672. C    TOOLPACK/1    Release: 2.3
  1673. C---------------------------------------------------------
  1674. C                  MAIN INTEGER STORAGE ARRAYS
  1675. C MAXLBG = Maximum number of DO statement labels per routine
  1676.         INTEGER MAXLBG
  1677.         PARAMETER(MAXLBG=100)
  1678.         COMMON / WORKC   /  IABEG(201),  ICRTNG(200), IPCNTG(75),
  1679.      *         IRCNTG(75),  ISBEG(201),  ISCNTG(75),  INSTG(250),
  1680.      *         KEXECG(75),  LABG(2,MAXLBG), KTOKG(81)
  1681.         INTEGER IABEG,ICRTNG,IPCNTG,IRCNTG,ISBEG,ISCNTG,INSTG,
  1682.      +          KEXECG,LABG,KTOKG
  1683.         SAVE /WORKC/
  1684.  
  1685.         INTEGER L,NDIML
  1686.         CHARACTER*5 NUMBER(3)
  1687.  
  1688.         EXTERNAL ZMESS,ZCHOUT,ZPTINT
  1689.  
  1690.         IF (TIEG) THEN
  1691. C Replacement for calls to ERROR
  1692.             CALL ZMESS('      SUBROUTINE E'//VNAMEG//'(S)',IODINS)
  1693.             CALL ZMESS('      CHARACTER*(*)S',IODINS)
  1694.             CALL ZMESS('      CALL REMARK(''USER PROGRAM HAS CALLED'//
  1695.      +                  '"ERROR"'')',IODINS)
  1696.             CALL ZMESS('      CALL REMARK(S)',IODINS)
  1697.             CALL ZMESS('      CALL R'//VNAMEG//'(-1)',IODINS)
  1698.             CALL ZMESS('      END',IODINS)
  1699. C Replacement for user's ZEXIT (cmd interpreters only)
  1700. C *** we always output this routine to save us remembering whether we came
  1701. C     across a call to ZEXIT or not. ***
  1702. C This will however not work unless the command interpreter calls ZQUIT
  1703. C to exit and not ZEXIT -- and the TIE implementation allows command
  1704. C interpreters to exit by using ZQUIT.
  1705.             CALL ZMESS('      SUBROUTINE W'//VNAMEG//'(I)',IODINS)
  1706.             CALL ZMESS('      INTEGER I',IODINS)
  1707.             CALL ZMESS('      EXTERNAL ZEXIT,ZINIT',IODINS)
  1708.             CALL ZMESS('      CALL ZEXIT(I)',IODINS)
  1709.             CALL ZMESS('      CALL ZINIT',IODINS)
  1710.             CALL ZMESS('      END',IODINS)
  1711. C Replacement for ZQUIT
  1712.             CALL ZMESS('      SUBROUTINE R'//VNAMEG//'(QUITV)',
  1713.      +                  IODINS)
  1714.             CALL ZMESS('      INTEGER QUITV',IODINS)
  1715.             CALL ZMESS('      INTEGER CREATE,ZGTCMD',IODINS)
  1716.         ELSE
  1717.             CALL ZMESS('      SUBROUTINE R'//VNAMEG,IODINS)
  1718.         END IF
  1719. C SPECIFICATION STATEMENTS
  1720.         CALL WCOMNS
  1721.         CALL ZMESS('      INTEGER ITLST,NUM,K,L,LINE',IODINS)
  1722.         NDIML = NRTNG + 1
  1723.         WRITE(NUMBER(1),9000) NDIML
  1724.         CALL ZMESS('      INTEGER IBEG('//NUMBER(1)//'),NOSEG(10)',
  1725.      +              IODINS)
  1726.         IF (HISTG) THEN
  1727.             CALL ZMESS('      INTEGER INHST,ITHST,IEOF',IODINS)
  1728.         END IF
  1729.         IF (RUNFN.NE.' ' .OR. ITRUNG.NE.0) THEN
  1730.             CALL ZMESS('      INTEGER ITRUN',IODINS)
  1731.         END IF
  1732.         IF (ASSRTG) THEN
  1733.             CALL ZMESS('      INTEGER JBEG('//NUMBER(1)//')',IODINS)
  1734.             CALL WFN(LSTFN,'LSTFN ')
  1735.             DO 100 L=1,NDIML
  1736.                 WRITE(NUMBER(1),9000) L
  1737.                 WRITE(NUMBER(2),9000) ISBEG(L)
  1738.                 WRITE(NUMBER(3),9000) IABEG(L)
  1739.                 CALL ZMESS('      DATA IBEG('//NUMBER(1)//'),JBEG('//
  1740.      +                      NUMBER(1)//')/'//NUMBER(2)//','//NUMBER(3)
  1741.      +                      //'/',IODINS)
  1742.  100        CONTINUE
  1743.         ELSE
  1744.             CALL WFN(LSTFN,'LSTFN ')
  1745.             DO 200 L=1,NDIML
  1746.                 CALL ZCHOUT('      DATA IBEG(',IODINS)
  1747.                 CALL ZPTINT(L,1,IODINS)
  1748.                 CALL ZCHOUT(')/',IODINS)
  1749.                 CALL ZPTINT(ISBEG(L),1,IODINS)
  1750.                 CALL ZMESS('/',IODINS)
  1751.  200        CONTINUE
  1752.         END IF
  1753.         CALL ZCHOUT('      DATA ITLST/',IODINS)
  1754.         CALL ZPTINT(ITLSTG,1,IODINS)
  1755.         CALL ZMESS('/',IODINS)
  1756.         IF (HISTG) THEN
  1757.             CALL ZCHOUT('      DATA INHST,ITHST/',IODINS)
  1758.             CALL ZPTINT(INHSTG,1,IODINS)
  1759.             CALL ZCHOUT(',',IODINS)
  1760.             CALL ZPTINT(ITHSTG,1,IODINS)
  1761.             CALL ZMESS('/',IODINS)
  1762.         END IF
  1763.         IF (RUNFN.NE.' ' .OR. ITRUNG.NE.0) THEN
  1764.             CALL ZCHOUT('      DATA ITRUN/',IODINS)
  1765.             CALL ZPTINT(ITRUNG,1,IODINS)
  1766.             CALL ZMESS('/',IODINS)
  1767.         END IF
  1768. C EMPTY TRACE BUFFER, IF REQD
  1769.         IF (TRACEG) CALL ZMESS('      CALL V'//VNAMEG//
  1770.      +                          '(-1,''TRACE=     '')',IODINS)
  1771. C Open listing file
  1772.         IF (LSTFN.EQ.'''') THEN
  1773.             IF (TIEG) THEN
  1774.                 CALL ZMESS('      CALL ZMESS(''Enter listing '//
  1775.      +                      'filename:'',1)',IODINS)
  1776.                 CALL ZMESS('      JUNK=ZGTCMD(LSTFN,0)',IODINS)
  1777.             ELSE
  1778.                 CALL ZMESS('      PRINT *,''Enter listing '//
  1779.      +                      'filename''',IODINS)
  1780.                 CALL ZMESS('      READ *,LSTFN',IODINS)
  1781.             END IF
  1782.         END IF
  1783.         IF (LSTFN.NE.' ') THEN
  1784.             IF (TIEG) THEN
  1785.                 CALL ZMESS('      ITLST=CREATE(LSTFN,1)',IODINS)
  1786.                 CALL ZMESS('      IF (ITLST..EQ..-1) RETURN',IODINS)
  1787.             ELSE
  1788.                 CALL ZMESS('      OPEN(ITLST,FILE=LSTFN,STATUS='''//
  1789.      +                      'UNKNOWN'')',IODINS)
  1790.             END IF
  1791.         END IF
  1792. C OUTPUT SEGMENT REPORT
  1793.         IF (TIEG) THEN
  1794.             CALL ZMESS('      CALL ZOBLNK(24,ITLST)',IODINS)
  1795.             CALL ZMESS('      CALL ZMESS(''SEGMENT EXECUTION FRE'//
  1796.      +                  'QUENCIES - CURRENT..'',ITLST)',IODINS)
  1797.             CALL ZMESS('      CALL PUTCH(10,ITLST)',IODINS)
  1798.             CALL ZMESS('      CALL ZOBLNK(17,ITLST)',IODINS)
  1799.             CALL ZMESS('      CALL ZMESS(''0     1     2  ''//',IODINS)
  1800.             CALL ZMESS('     +''   3     4     5     6     7     8'//
  1801.      +                  '     9'',ITLST)',IODINS)
  1802.             CALL ZMESS('      CALL PUTCH(10,ITLST)',IODINS)
  1803.         ELSE
  1804.             CALL ZMESS('      WRITE (ITLST,110)',IODINS)
  1805.             CALL ZMESS ('  110 FORMAT (''1'',24X,'//
  1806.      +            '''SEGMENT EXECUTION FREQUENCIES - CURRENT'')',IODINS)
  1807.             CALL ZMESS('      WRITE (ITLST,120) (L,L=1,9)',IODINS)
  1808.             CALL ZMESS ('  120 FORMAT (''0'',17X,''0'',9(5X,I1),/)',
  1809.      +                   IODINS)
  1810.         END IF
  1811.         WRITE(NUMBER(1),9000) NMSEG
  1812.         CALL ZMESS('      CALL S'//VNAMEG//'(I'//VNAMEG//','//
  1813.      +              NUMBER(1)//',IBEG,ITLST)',IODINS)
  1814.         IF (TIEG) THEN
  1815.             CALL ZMESS('      CALL PUTCH(10,ITLST)',IODINS)
  1816.             CALL ZMESS('      CALL ZOBLNK(36,ITLST)',IODINS)
  1817.             CALL ZMESS('      CALL ZMESS(''SEGMENTS NOT EXECUTED'','//
  1818.      +                  'ITLST)',IODINS)
  1819.         ELSE
  1820.             CALL ZMESS('      WRITE (ITLST,130)',IODINS)
  1821.             CALL ZMESS ('  130 FORMAT (''1'',36X,'//
  1822.      +                   '''SEGMENTS NOT EXECUTED'',/)',IODINS)
  1823.         END IF
  1824.         CALL ZMESS('      LINE=2',IODINS)
  1825.         CALL ZMESS('      NUM=0',IODINS)
  1826. C OUTPUT SEGMENTS NOT EXECUTED
  1827.         CALL ZMESS('      DO 100 L=1,'//NUMBER(1),IODINS)
  1828.         CALL ZMESS('      IF (I'//VNAMEG//'(L)..EQ..0) THEN',IODINS)
  1829.         CALL ZMESS('      NUM=NUM+1',IODINS)
  1830.         CALL ZMESS('      NOSEG(NUM)=L',IODINS)
  1831.         CALL ZMESS('      END IF',IODINS)
  1832.         CALL ZMESS('      IF (NUM..EQ..10..OR..(L..EQ..'//NUMBER(1)//
  1833.      +              '..AND..NUM..GT..0))THEN',IODINS)
  1834.         CALL ZMESS('      CALL Q'//VNAMEG//'(LINE,ITLST)',IODINS)
  1835.         IF (TIEG) THEN
  1836.             CALL ZMESS('      DO 200 K=1,NUM',IODINS)
  1837.             CALL ZMESS('      CALL ZPTINT(NOSEG(K),7,ITLST)',
  1838.      +                  IODINS)
  1839.             CALL ZMESS('      IF(MOD(K,10)..EQ..0) CALL '//
  1840.      +                  'PUTCH(10,ITLST)',IODINS)
  1841.             CALL ZMESS(' 200  CONTINUE',IODINS)
  1842.         ELSE
  1843.             CALL ZMESS('      WRITE (ITLST,140) (NOSEG(K),K=1,NUM)',
  1844.      +                  IODINS)
  1845.             CALL ZMESS('  140 FORMAT (10(2X,I5))',IODINS)
  1846.         END IF
  1847.         CALL ZMESS('      NUM=0',IODINS)
  1848.         CALL ZMESS('      END IF',IODINS)
  1849.         CALL ZMESS(' 100  CONTINUE',IODINS)
  1850. C Convert number of assertions to a character string
  1851.         WRITE(NUMBER(2),9000) NMASRG
  1852. C Do single-run data if required
  1853.         IF (RUNFN.NE.' ' .OR. ITRUNG.NE.0) THEN
  1854.             CALL ZMESS('      CALL O'//VNAMEG//'(I'//VNAMEG//','//
  1855.      +                  NUMBER(1)//',ITRUN,..TRUE..)',IODINS)
  1856. C Single-run assertion data if required
  1857.             IF (ASSRTG) CALL ZMESS('      CALL O'//VNAMEG//'(J'//VNAMEG
  1858.      +                     //','//NUMBER(2)//',ITRUN,..TRUE..)',IODINS)
  1859.             IF (TIEG) THEN
  1860.                 CALL ZMESS('      CALL CLOSE(ITRUN)',IODINS)
  1861.             ELSE
  1862.                 CALL ZMESS('      CLOSE(ITRUN)',IODINS)
  1863.             END IF
  1864.         END IF
  1865. C Input old segment history, if required
  1866.         IF (HISTG) THEN
  1867.             CALL ZMESS('      CALL P'//VNAMEG//'(I'//VNAMEG//','//
  1868.      +                  NUMBER(1)//',IEOF,INHST,..FALSE..)',IODINS)
  1869.         END IF
  1870. C Output assertion report, if required
  1871.         IF (ASSRTG) THEN
  1872.             IF (TIEG) THEN
  1873.                 CALL ZMESS('      CALL PUTCH(10,ITLST)',IODINS)
  1874.                 CALL ZMESS('      CALL ZOBLNK(24,ITLST)',IODINS)
  1875.                 CALL ZMESS('      CALL ZMESS(''ASSERTION FAILURE FRE'//
  1876.      +                      'QUENCIES - CURRENT'',ITLST)',IODINS)
  1877.                 CALL ZMESS('      CALL PUTCH(10,ITLST)',IODINS)
  1878.                 CALL ZMESS('      CALL ZOBLNK(17,ITLST)',IODINS)
  1879.                 CALL ZMESS('      CALL ZMESS(''0     1    ''//',IODINS)
  1880.                 CALL ZMESS('     +'' 2     3     4     5     6     7'//
  1881.      +                  '     8     9'',ITLST)',IODINS)
  1882.                 CALL ZMESS('      CALL PUTCH(10,ITLST)',IODINS)
  1883.             ELSE
  1884.                 CALL ZMESS('      WRITE (ITLST,150)',IODINS)
  1885.                 CALL ZMESS ('  150 FORMAT (''1'',24X,'//
  1886.      +        '''ASSERTION FAILURE FREQUENCIES - CURRENT'')',IODINS)
  1887.                 CALL ZMESS('      WRITE (ITLST,120) (L,L=1,9)',
  1888.      +                      IODINS)
  1889.             END IF
  1890.             CALL ZMESS('      CALL S'//VNAMEG//'(J'//VNAMEG//','//
  1891.      +                  NUMBER(1)//',JBEG,ITLST)',IODINS)
  1892. C Input old assertion history, if required
  1893.             IF (HISTG) THEN
  1894.                 CALL ZMESS('      IF (IEOF..EQ..0) CALL P'//VNAMEG//
  1895.      +                             '(J'//VNAMEG//','//NUMBER(2)//
  1896.      +                             ',IEOF,INHST,..TRUE..)',IODINS)
  1897.             END IF
  1898.         END IF
  1899.         IF (HISTG) THEN
  1900. C Output new segment history, if required
  1901.             IF (ITHSTG.EQ.INHSTG) CALL ZMESS('      ITHST=INHST',
  1902.      +                                        IODINS)
  1903.             CALL ZMESS('      CALL O'//VNAMEG//'(I'//VNAMEG//','//
  1904.      +                  NUMBER(1)//',ITHST,..FALSE..)',IODINS)
  1905. C Output new assertion history, if required
  1906.             IF (ASSRTG) CALL ZMESS('      CALL O'//VNAMEG//'(J'//VNAMEG
  1907.      +                    //','//NUMBER(2)//',ITHST,..FALSE..)',IODINS)
  1908.             IF (TIEG) THEN
  1909.                 CALL ZMESS('      CALL CLOSE(INHST)',IODINS)
  1910.                 IF (INHSTG.NE.ITHSTG .OR. OHSTFN.NE.' ') CALL ZMESS(
  1911.      +              '      CALL CLOSE(ITHST)',IODINS)
  1912.             ELSE
  1913.                 CALL ZMESS('      CLOSE(INHST)',IODINS)
  1914.                 IF (INHSTG.NE.ITHSTG .OR. OHSTFN.NE.' ') CALL ZMESS(
  1915.      +              '      CLOSE(ITHST)',IODINS)
  1916.             END IF
  1917.         END IF
  1918. C Actually terminate the program.
  1919.         IF (TIEG) THEN
  1920.             CALL ZMESS ('      CALL ZQUIT(QUITV)',IODINS)
  1921.         ELSE
  1922.             CALL ZMESS ('      STOP',IODINS)
  1923.         END IF
  1924.         CALL ZMESS('      END',IODINS)
  1925.  
  1926. 9000    FORMAT(SS,I5)
  1927.         END
  1928. C ----------------------------------------------------------------------
  1929. C
  1930. C       W R E P T S   -   Insert report-generation routine
  1931. C                         instrumentation
  1932.  
  1933.         SUBROUTINE WREPTS
  1934.  
  1935. C---------------------------------------------------------
  1936. C    TOOLPACK/1    Release: 2.3
  1937. C---------------------------------------------------------
  1938. C                  CONTROL VARIABLES
  1939.       COMMON / CNTRLC  /    IERRG,       IFTYPG,      ITYPEG,
  1940.      *         IUNITG,      JERRG,       KERRG,       LABFLG,
  1941.      *         LINEG,       LTYPEG,      NBUFFG,      NTOKG,
  1942.      *         NTOK2G,      NTOK3G,      NTOK4G,      NCOMG,
  1943.      *         NCRTNG,      NDDICG,      NEDICG,      NLABG,
  1944.      *         NMASRG,      NMSEG,       NRDICG,      NRTNG,
  1945.      *         NSTMG,       NTREEG,      NTYPEG
  1946.  
  1947.         INTEGER IERRG,IFTYPG,ITYPEG,IUNITG,JERRG,KERRG,LABFLG,LINEG,
  1948.      +          LTYPEG,NBUFFG,NTOKG,NTOK2G,NTOK3G,NTOK4G,NCOMG,NCRTNG,
  1949.      +          NDDICG,NEDICG,NLABG,NMASRG,NMSEG,NRDICG,NRTNG,NSTMG,
  1950.      +          NTREEG,NTYPEG
  1951.  
  1952.         SAVE /CNTRLC/
  1953.  
  1954. C---------------------------------------------------------
  1955. C    TOOLPACK/1    Release: 2.3
  1956. C---------------------------------------------------------
  1957. C Dictionary
  1958. C   MAXDDG = Maximum number of dimension names in dictionary
  1959. C   MAXRDG = Maximum number of routine names in dictionary
  1960.         INTEGER MAXDDG,MAXRDG
  1961.         PARAMETER(MAXDDG=150,MAXRDG=250)
  1962.         COMMON /ANDICT/ DDICTG,RDICTG
  1963.         CHARACTER*6 DDICTG(MAXDDG),RDICTG(MAXRDG)
  1964.         SAVE /ANDICT/
  1965. C---------------------------------------------------------
  1966. C    TOOLPACK/1    Release: 2.3
  1967. C---------------------------------------------------------
  1968.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1969.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  1970.  
  1971.         SAVE /IO/
  1972.  
  1973. C---------------------------------------------------------
  1974. C    TOOLPACK/1    Release: 2.3
  1975. C---------------------------------------------------------
  1976. C Option Settings
  1977.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  1978.      +                 MTREQG,TIEG,ITRUNG
  1979.  
  1980.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  1981.      +          ITRUNG
  1982.         LOGICAL TIEG
  1983.  
  1984.         SAVE /OPTSC/
  1985.  
  1986. C---------------------------------------------------------
  1987. C    TOOLPACK/1    Release: 2.3
  1988. C---------------------------------------------------------
  1989.         COMMON/ANVNAM/VNAMEG
  1990.         CHARACTER*5 VNAMEG
  1991.         SAVE/ANVNAM/
  1992. C---------------------------------------------------------
  1993. C    TOOLPACK/1    Release: 2.3
  1994. C---------------------------------------------------------
  1995. C                  MAIN INTEGER STORAGE ARRAYS
  1996. C MAXLBG = Maximum number of DO statement labels per routine
  1997.         INTEGER MAXLBG
  1998.         PARAMETER(MAXLBG=100)
  1999.         COMMON / WORKC   /  IABEG(201),  ICRTNG(200), IPCNTG(75),
  2000.      *         IRCNTG(75),  ISBEG(201),  ISCNTG(75),  INSTG(250),
  2001.      *         KEXECG(75),  LABG(2,MAXLBG), KTOKG(81)
  2002.         INTEGER IABEG,ICRTNG,IPCNTG,IRCNTG,ISBEG,ISCNTG,INSTG,
  2003.      +          KEXECG,LABG,KTOKG
  2004.         SAVE /WORKC/
  2005.  
  2006.         INTEGER L
  2007.         EXTERNAL ZCHOUT,ZMESS,ZPTINT,PUTCH
  2008.  
  2009.         CALL ZMESS('      SUBROUTINE S'//VNAMEG//
  2010.      +              '(IARY,IDIM,NBEG,ITLST)',IODINS)
  2011.         CALL ZCHOUT('      INTEGER IDIM,IARY(IDIM),NBEG(',IODINS)
  2012.         CALL ZPTINT(NRTNG+1,1,IODINS)
  2013.         CALL ZMESS('),JTENS,ITLST,I,J,K,L',IODINS)
  2014.         CALL ZMESS('      INTEGER ILOWER,IUPPER,JEND,JSTART,JUNITS,LINE'
  2015.      +            ,IODINS)
  2016.         CALL ZMESS('      CHARACTER*24 KOUT(10),LOUT',IODINS)
  2017.         CALL ZCHOUT('      CHARACTER*6 NAM(',IODINS)
  2018.         CALL ZPTINT(NRTNG,1,IODINS)
  2019.         CALL ZMESS(')',IODINS)
  2020.         IF (TIEG) CALL ZMESS('      CHARACTER*80 BUFFER',IODINS)
  2021. C Output report formats
  2022.         CALL ZMESS('      DATA KOUT',IODINS)
  2023.         CALL ZMESS('     */''(1X,I5,''''X'''',6X,10(1X,I5))''',IODINS)
  2024.         CALL ZMESS('     *,''(1X,I5,''''X'''',12X,9(1X,I5))''',IODINS)
  2025.         CALL ZMESS('     *,''(1X,I5,''''X'''',18X,8(1X,I5))''',IODINS)
  2026.         CALL ZMESS('     *,''(1X,I5,''''X'''',24X,7(1X,I5))''',IODINS)
  2027.         CALL ZMESS('     *,''(1X,I5,''''X'''',30X,6(1X,I5))''',IODINS)
  2028.         CALL ZMESS('     *,''(1X,I5,''''X'''',36X,5(1X,I5))''',IODINS)
  2029.         CALL ZMESS('     *,''(1X,I5,''''X'''',42X,4(1X,I5))''',IODINS)
  2030.         CALL ZMESS('     *,''(1X,I5,''''X'''',48X,3(1X,I5))''',IODINS)
  2031.         CALL ZMESS('     *,''(1X,I5,''''X'''',54X,2(1X,I5))''',IODINS)
  2032.         CALL ZMESS('     *,''(1X,I5,''''X'''',60X,1(1X,I5))''/',IODINS)
  2033. C User routine names
  2034.         DO 100 L=1,NRTNG
  2035.             CALL ZCHOUT('      DATA NAM(',IODINS)
  2036.             CALL ZPTINT(L,1,IODINS)
  2037.             CALL ZMESS(')/'''//RDICTG(ICRTNG(L))//''' /',IODINS)
  2038.   100   CONTINUE
  2039. C The program proper
  2040.         CALL ZMESS('      LINE=4',IODINS)
  2041.         CALL ZCHOUT('      DO 110 I=1,',IODINS)
  2042.         CALL ZPTINT(NRTNG,1,IODINS)
  2043.         CALL PUTCH(10,IODINS)
  2044.         CALL ZMESS('      ILOWER=NBEG(I)',IODINS)
  2045.         CALL ZMESS('      IUPPER=NBEG(I+1)-1',IODINS)
  2046.         CALL ZMESS('      IF (ILOWER..LE..IUPPER) THEN',IODINS)
  2047.         CALL ZMESS('      CALL Q'//VNAMEG//'(LINE,ITLST)',IODINS)
  2048.         IF (TIEG) THEN
  2049.             CALL ZMESS('      CALL ZMESS(''       ''//NAM(I),ITLST)',
  2050.      +                  IODINS)
  2051.         ELSE
  2052.             CALL ZMESS('      WRITE (ITLST,120) NAM(I)',IODINS)
  2053.         END IF
  2054.         CALL ZMESS('      JSTART=ILOWER',IODINS)
  2055.         CALL ZMESS('      JTENS=ILOWER/10',IODINS)
  2056.         CALL ZMESS('      JUNITS=ILOWER - JTENS*10',IODINS)
  2057.         CALL ZMESS('      IF (JUNITS..GT..0) THEN',IODINS)
  2058.         CALL ZMESS('      JEND=JTENS*10 + 9',IODINS)
  2059.         CALL ZMESS('      LOUT=KOUT(JUNITS+1)',IODINS)
  2060.         CALL ZMESS('      CALL Q'//VNAMEG//'(LINE,ITLST)',IODINS)
  2061.         CALL ZMESS('      IF (JEND..LT..IUPPER) THEN',IODINS)
  2062.         IF (TIEG) THEN
  2063.             CALL ZMESS('      WRITE(BUFFER,LOUT) JTENS,'//
  2064.      +                  '(IARY(L),L=ILOWER,JEND)',IODINS)
  2065.             CALL ZMESS('      CALL ZMESS(BUFFER,ITLST)',IODINS)
  2066.             CALL ZMESS('      ELSE',IODINS)
  2067.             CALL ZMESS('      WRITE (BUFFER,LOUT) JTENS,'//
  2068.      +                  '(IARY(L),L=ILOWER,IUPPER)',IODINS)
  2069.             CALL ZMESS('      CALL ZMESS(BUFFER,ITLST)',IODINS)
  2070.         ELSE
  2071.             CALL ZMESS('      WRITE (ITLST,LOUT) JTENS,'//
  2072.      +                  '(IARY(L),L=ILOWER,JEND)',IODINS)
  2073.             CALL ZMESS('      ELSE',IODINS)
  2074.             CALL ZMESS('      WRITE (ITLST,LOUT) JTENS,'//
  2075.      +                  '(IARY(L),L=ILOWER,IUPPER)',IODINS)
  2076.         END IF
  2077.         CALL ZMESS('      GO TO 110',IODINS)
  2078.         CALL ZMESS('      END IF',IODINS)
  2079.         CALL ZMESS('      JSTART=JEND+1',IODINS)
  2080.         CALL ZMESS('      END IF',IODINS)
  2081.         CALL ZMESS('      LOUT=KOUT(1)',IODINS)
  2082.         CALL ZMESS('      DO 100 J=JSTART,IUPPER,10',IODINS)
  2083.         CALL ZMESS('      JTENS=J/10',IODINS)
  2084.         CALL ZMESS('      JEND=J+9',IODINS)
  2085.         CALL ZMESS('      IF (JEND..GT..IUPPER) JEND=IUPPER',IODINS)
  2086.         CALL ZMESS('      CALL Q'//VNAMEG//'(LINE,ITLST)',IODINS)
  2087.         IF (TIEG) THEN
  2088.             CALL ZMESS('      WRITE(BUFFER,LOUT) JTENS,'//
  2089.      +                  '(IARY(L),L=J,JEND)',IODINS)
  2090.             CALL ZMESS('  100 CALL ZMESS(BUFFER(1:72),ITLST)',IODINS)
  2091.         ELSE
  2092.             CALL ZMESS('  100 WRITE (ITLST,LOUT) JTENS,'//
  2093.      +                  '(IARY(L),L=J,JEND)',IODINS)
  2094.         END IF
  2095.         CALL ZMESS('      END IF',IODINS)
  2096.         CALL ZMESS('  110 CONTINUE',IODINS)
  2097.         CALL ZMESS('      RETURN',IODINS)
  2098.         CALL ZMESS('  120 FORMAT (8X,A6)',IODINS)
  2099.         CALL ZMESS('      END',IODINS)
  2100.  
  2101.         END
  2102. C ----------------------------------------------------------------------
  2103. C
  2104. C       W T B U F S   -   Insert trace control routine instrumentation
  2105. C
  2106.  
  2107.         SUBROUTINE WTBUFS
  2108.  
  2109. C---------------------------------------------------------
  2110. C    TOOLPACK/1    Release: 2.3
  2111. C---------------------------------------------------------
  2112.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  2113.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  2114.  
  2115.         SAVE /IO/
  2116.  
  2117. C---------------------------------------------------------
  2118. C    TOOLPACK/1    Release: 2.3
  2119. C---------------------------------------------------------
  2120. C                  LOGICAL VARIABLES
  2121.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  2122.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  2123.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  2124.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  2125.      *         TREEG
  2126.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  2127.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  2128.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  2129.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  2130.  
  2131.         SAVE /LOGIC/
  2132.  
  2133. C---------------------------------------------------------
  2134. C    TOOLPACK/1    Release: 2.3
  2135. C---------------------------------------------------------
  2136. C Option Settings
  2137.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  2138.      +                 MTREQG,TIEG,ITRUNG
  2139.  
  2140.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  2141.      +          ITRUNG
  2142.         LOGICAL TIEG
  2143.  
  2144.         SAVE /OPTSC/
  2145.  
  2146. C---------------------------------------------------------
  2147. C    TOOLPACK/1    Release: 2.3
  2148. C---------------------------------------------------------
  2149.         COMMON/ANVNAM/VNAMEG
  2150.         CHARACTER*5 VNAMEG
  2151.         SAVE/ANVNAM/
  2152.  
  2153.         EXTERNAL ZCHOUT,ZMESS,ZPTINT
  2154.  
  2155. *$AS$ (TRACEG)
  2156.         CALL ZMESS('      SUBROUTINE T'//VNAMEG//'(NSEG)',IODINS)
  2157.         CALL WCOMNS
  2158.         CALL TCOMNS
  2159.         CALL ZMESS('      SAVE ICIRCL,ICOUNT,IFIRST,IPT',IODINS)
  2160.         CALL ZCHOUT('      DIMENSION ICIRCL(',IODINS)
  2161.         CALL ZPTINT(MCIRCG,1,IODINS)
  2162.         CALL ZMESS(')',IODINS)
  2163.         CALL ZCHOUT('      DATA ICOUNT,IFIRST,IPT/0,1,',IODINS)
  2164.         CALL ZPTINT(MCIRCG,1,IODINS)
  2165.         CALL ZMESS('/',IODINS)
  2166.         CALL ZMESS('      I'//VNAMEG//'(NSEG)=I'//VNAMEG//'(NSEG)+1',
  2167.      +              IODINS)
  2168.         CALL ZMESS('      IF (IFIRST..EQ..1) THEN',IODINS)
  2169.         CALL ZMESS('      CALL U'//VNAMEG,IODINS)
  2170.         CALL ZMESS('      IFIRST=0',IODINS)
  2171.         CALL ZMESS('      IF (IFLAG..EQ..1) THEN',IODINS)
  2172.         CALL ZCHOUT('      DO 90 L=1,',IODINS)
  2173.         CALL ZPTINT(MCIRCG,1,IODINS)
  2174.         CALL PUTCH(10,IODINS)
  2175.         CALL ZMESS(' 90   ICIRCL(L)=0',IODINS)
  2176.         CALL ZMESS('      END IF',IODINS)
  2177.         CALL ZMESS('      END IF',IODINS)
  2178.         CALL ZMESS('      IF (NREQ..GT..0) THEN',IODINS)
  2179.         CALL ZMESS('      IF (IFLAG..EQ..1) THEN',IODINS)
  2180.         CALL ZMESS('      DO 110 L=NREQ,1,-1',IODINS)
  2181.         CALL ZMESS('      IF(KVAL(L)..EQ..LPRE..AND..'//
  2182.      +             'ISEG(L)..EQ..NSEG)THEN',IODINS)
  2183.         CALL ZMESS('      CALL V'//VNAMEG//'(-1,''TRACE=     '')',
  2184.      +              IODINS)
  2185.         CALL ZCHOUT('      ICONST=IPT+',IODINS)
  2186.         CALL ZPTINT(MCIRCG-1,1,IODINS)
  2187.         CALL ZMESS('-JVAL(L)',IODINS)
  2188.         CALL ZMESS('      DO 100 K=1,JVAL(L)',IODINS)
  2189.         CALL ZCHOUT(' 100  CALL V'//VNAMEG//'(ICIRCL(MOD(ICONST+K,',
  2190.      +             IODINS)
  2191.         CALL ZPTINT(MCIRCG,1,IODINS)
  2192.         CALL ZMESS(')+1),''TRACE(PRE)='')',IODINS)
  2193.         CALL ZCHOUT('      IPT=MOD(IPT,',IODINS)
  2194.         CALL ZPTINT(MCIRCG,1,IODINS)
  2195.         CALL ZMESS(')+1',IODINS)
  2196.         CALL ZMESS('      ICIRCL(IPT)=NSEG',IODINS)
  2197.         CALL ZMESS('      CALL V'//VNAMEG//'(NSEG,''TRACE(PRE)='')',
  2198.      +              IODINS)
  2199.         CALL ZMESS('      CALL V'//VNAMEG//'(-1,''TRACE(PRE)='')',
  2200.      +              IODINS)
  2201.         CALL ZMESS('      GO TO 120',IODINS)
  2202.         CALL ZMESS('      END IF',IODINS)
  2203.         CALL ZMESS('  110 CONTINUE',IODINS)
  2204.         CALL ZCHOUT('      IPT=MOD(IPT,',IODINS)
  2205.         CALL ZPTINT(MCIRCG,1,IODINS)
  2206.         CALL ZMESS(')+1',IODINS)
  2207.         CALL ZMESS('      ICIRCL(IPT)=NSEG',IODINS)
  2208.         CALL ZMESS('      END IF',IODINS)
  2209.         CALL ZMESS('  120 ITHIS=0',IODINS)
  2210.         CALL ZMESS('      DO 130 L=1,NREQ',IODINS)
  2211.         CALL ZMESS('      IF (KVAL(L)..EQ..LPOST..AND..ISEG(L)..EQ..',
  2212.      +              IODINS)
  2213.         CALL ZMESS('     + NSEG..AND..JVAL(L)..GT..ICOUNT) THEN',IODINS)
  2214.         CALL ZMESS('      ICOUNT=JVAL(L)+1',IODINS)
  2215.         CALL ZMESS('      ELSEIF(KVAL(L)..EQ..LRANGE..AND..ISEG(L)',
  2216.      +             IODINS)
  2217.         CALL ZMESS('     + ..LE..NSEG..AND..JVAL(L)..GE..NSEG)THEN',
  2218.      +             IODINS)
  2219.         CALL ZMESS('      ITHIS=1',IODINS)
  2220.         CALL ZMESS('      END IF',IODINS)
  2221.         CALL ZMESS('  130 CONTINUE',IODINS)
  2222.         CALL ZMESS('      IF (ICOUNT..GT..0) THEN',IODINS)
  2223.         CALL ZMESS('      ITHIS=1',IODINS)
  2224.         CALL ZMESS('      ICOUNT=ICOUNT-1',IODINS)
  2225.         CALL ZMESS('      END IF',IODINS)
  2226.         CALL ZMESS('      IF (ITHIS..EQ..1) CALL V'//VNAMEG//'(NSEG,'//
  2227.      +              '''TRACE=     '')',IODINS)
  2228.         CALL ZMESS('      END IF',IODINS)
  2229.         CALL ZMESS('      RETURN',IODINS)
  2230.         CALL ZMESS('      END',IODINS)
  2231.  
  2232.         END
  2233. C ----------------------------------------------------------------------
  2234. C
  2235. C       W T I N S   -   Insert trace input routine instrumentation
  2236. C
  2237.  
  2238.         SUBROUTINE WTINS
  2239.  
  2240. C---------------------------------------------------------
  2241. C    TOOLPACK/1    Release: 2.3
  2242. C---------------------------------------------------------
  2243. C Filenames
  2244.         COMMON/ANFNAM/IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  2245.         CHARACTER*81 IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  2246.         SAVE /ANFNAM/
  2247. C---------------------------------------------------------
  2248. C    TOOLPACK/1    Release: 2.3
  2249. C---------------------------------------------------------
  2250.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  2251.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  2252.  
  2253.         SAVE /IO/
  2254.  
  2255. C---------------------------------------------------------
  2256. C    TOOLPACK/1    Release: 2.3
  2257. C---------------------------------------------------------
  2258. C                  LOGICAL VARIABLES
  2259.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  2260.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  2261.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  2262.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  2263.      *         TREEG
  2264.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  2265.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  2266.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  2267.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  2268.  
  2269.         SAVE /LOGIC/
  2270.  
  2271. C---------------------------------------------------------
  2272. C    TOOLPACK/1    Release: 2.3
  2273. C---------------------------------------------------------
  2274. C Option Settings
  2275.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  2276.      +                 MTREQG,TIEG,ITRUNG
  2277.  
  2278.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  2279.      +          ITRUNG
  2280.         LOGICAL TIEG
  2281.  
  2282.         SAVE /OPTSC/
  2283.  
  2284. C---------------------------------------------------------
  2285. C    TOOLPACK/1    Release: 2.3
  2286. C---------------------------------------------------------
  2287.         COMMON/ANVNAM/VNAMEG
  2288.         CHARACTER*5 VNAMEG
  2289.         SAVE/ANVNAM/
  2290.  
  2291. *$AS$ (TRACEG)
  2292.         CALL ZMESS('      SUBROUTINE U'//VNAMEG,IODINS)
  2293.         CALL TCOMNS
  2294.         IF (.NOT.TIEG) THEN
  2295.             CALL ZMESS('      CHARACTER IOP',IODINS)
  2296.         ELSE
  2297.             CALL ZMESS('      INTEGER BUFF(134),IOP,JUNK',IODINS)
  2298.             CALL ZMESS('      INTEGER GETLIN,CTOI',IODINS)
  2299.             CALL ZMESS('      INTEGER OPEN,CREATE',IODINS)
  2300.         END IF
  2301.         CALL WFN2(ITRAFN,'ITRAFN',OTRAFN,'OTRAFN')
  2302.         CALL ZCHOUT('      DATA INTRA/',IODINS)
  2303.         CALL ZPTINT(INTRAG,1,IODINS)
  2304.         CALL ZMESS('/',IODINS)
  2305.         CALL ZCHOUT('      ITTRA=',IODINS)
  2306.         CALL ZPTINT(ITTRAG,1,IODINS)
  2307.         CALL PUTCH(10,IODINS)
  2308.         CALL ZMESS('      IFLAG=0',IODINS)
  2309.         CALL ZMESS('      LPRE=1',IODINS)
  2310.         CALL ZMESS('      LPOST=2',IODINS)
  2311.         CALL ZMESS('      LRANGE=3',IODINS)
  2312.         CALL ZMESS('      NREQ=0',IODINS)
  2313.         IF (TIEG) THEN
  2314.             CALL ZMESS('      CALL ZINIT',IODINS)
  2315.             IF (ITRAFN.EQ.'''') THEN
  2316.                 CALL ZMESS('      CALL ZMESS(''Input trace input '''//
  2317.      +                      'filename'',1)',IODINS)
  2318.                 CALL ZMESS('      JUNK=GETLIN(ITRAFN,0)',IODINS)
  2319.             END IF
  2320.             IF (ITRAFN.NE.' ') THEN
  2321.                 CALL ZMESS('      INTRA=OPEN(ITRAFN,0)',IODINS)
  2322.                 CALL ZMESS('      IF (INTRA..EQ..-1) CALL ERROR('//
  2323.      +                      '''NO TRACE INPUT'')',IODINS)
  2324.             END IF
  2325.             IF (OTRAFN.EQ.'''') THEN
  2326.                 CALL ZMESS('      CALL ZMESS(''Input trace output '//
  2327.      +                      'filename'',1)',IODINS)
  2328.                 CALL ZMESS('      JUNK=GETLIN(OTRAFN,0)',IODINS)
  2329.             END IF
  2330.             IF (OTRAFN.NE.' ') THEN
  2331.                 CALL ZMESS('      ITTRA=CREATE(OTRAFN,1)',IODINS)
  2332.                 CALL ZMESS('      IF (ITTRA..EQ..-1) CALL ERROR('//
  2333.      +                      '''NO TRACE OUTPUT'')',IODINS)
  2334.             END IF
  2335.             CALL ZMESS('      CALL ZMESS(''TRACE OUTPUT REQUESTS'','//
  2336.      +                  'ITTRA)',IODINS)
  2337.             CALL ZMESS(' 100  IF (GETLIN(BUFF,INTRA)..EQ..-100) GOTO '//
  2338.      +                  '120',IODINS)
  2339.             CALL ZMESS('      JUNK=1',IODINS)
  2340.             CALL ZMESS('      MSEG=CTOI(BUFF,JUNK)',IODINS)
  2341.             CALL ZMESS('      IF (MSEG..EQ..0) GOTO 120',IODINS)
  2342.             CALL ZMESS('      IOP=BUFF(JUNK)',IODINS)
  2343.             CALL ZMESS('      JUNK=JUNK+1',IODINS)
  2344.             CALL ZMESS('      NVAL=CTOI(BUFF,JUNK)',IODINS)
  2345.             CALL ZMESS('      CALL ZCHOUT(''TRACE='',ITTRA)',IODINS)
  2346.             CALL ZMESS('      CALL PUTLIN(BUFF,ITTRA)',IODINS)
  2347.         ELSE
  2348.             IF (ITRAFN.EQ.'''') THEN
  2349.                 CALL ZMESS('      PRINT *,''Trace input file?''',
  2350.      +                      IODINS)
  2351.                 CALL ZMESS('      READ (*,''(A 81)'') ITRAFN',
  2352.      +                      IODINS)
  2353.             END IF
  2354.             IF (ITRAFN.NE.' ') THEN
  2355.                 CALL ZMESS('      OPEN(INTRA,FILE=ITRAFN,STATUS='//
  2356.      +                      '''OLD'')',IODINS)
  2357.                 CALL ZMESS('      REWIND(INTRA,ERR=125)',IODINS)
  2358.                 CALL ZMESS('  125 CONTINUE',IODINS)
  2359.             END IF
  2360.             IF (OTRAFN.EQ.'''') THEN
  2361.                 CALL ZMESS('      PRINT *,''Trace output file?''',
  2362.      +                      IODINS)
  2363.                 CALL ZMESS('      READ (*,''(A 81)'') OTRAFN',
  2364.      +                      IODINS)
  2365.             END IF
  2366.             IF (OTRAFN.NE.' ') THEN
  2367.                 CALL ZMESS('      OPEN(ITTRA,FILE=OTRAFN,STATUS='//
  2368.      +                      '''UNKNOWN'')',IODINS)
  2369.                 CALL ZMESS('      REWIND(ITTRA,ERR=130)',IODINS)
  2370.                 CALL ZMESS('  130 CONTINUE',IODINS)
  2371.             END IF
  2372.             CALL ZMESS('      WRITE (ITTRA,140)',IODINS)
  2373.             CALL ZMESS('  140 FORMAT (''1'',2X,''TRACE OUTPUT REQU'//
  2374.      +                  'ESTS'')',IODINS)
  2375.             CALL ZMESS('  100 READ (INTRA,150,END=120) MSEG,IOP,NVAL',
  2376.      +                  IODINS)
  2377.             CALL ZMESS('      IF (MSEG..EQ..0) GO TO 120',IODINS)
  2378.             CALL ZMESS('      WRITE (ITTRA,160)''TRACE='',MSEG,IOP,N'//
  2379.      +                  'VAL',IODINS)
  2380.         END IF
  2381.         CALL ZMESS('      IF(MSEG..GT..0..AND..NVAL..GT..0)THEN',IODINS)
  2382.         CALL ZCHOUT('      IF (NREQ..LT..',IODINS)
  2383.         CALL ZPTINT(MTREQG,1,IODINS)
  2384.         CALL ZMESS(') THEN',IODINS)
  2385.         CALL ZMESS('      NREQ=NREQ+1',IODINS)
  2386.         CALL ZMESS('      ISEG(NREQ)=MSEG',IODINS)
  2387.         CALL ZMESS('      JVAL(NREQ)=NVAL',IODINS)
  2388.         IF (TIEG) THEN
  2389.             CALL ZMESS('      IF(IOP..EQ..45)THEN',IODINS)
  2390.         ELSE
  2391.             CALL ZMESS('      IF (IOP..EQ..''-'') THEN',IODINS)
  2392.         END IF
  2393.         CALL ZMESS('      KVAL(NREQ)=LPRE',IODINS)
  2394.         CALL ZMESS('      IFLAG=1',IODINS)
  2395.         CALL ZCHOUT('      IF (JVAL(NREQ)..GT..',IODINS)
  2396.         CALL ZPTINT(MCIRCG,1,IODINS)
  2397.         CALL ZCHOUT(') JVAL(NREQ)=',IODINS)
  2398.         CALL ZPTINT(MCIRCG,1,IODINS)
  2399.         CALL PUTCH(10,IODINS)
  2400.         IF (TIEG) THEN
  2401.             CALL ZMESS('      ELSEIF(IOP..EQ..43)THEN',IODINS)
  2402.         ELSE
  2403.             CALL ZMESS('      ELSEIF (IOP..EQ..''+'') THEN',IODINS)
  2404.         END IF
  2405.         CALL ZMESS('      KVAL(NREQ)=LPOST',IODINS)
  2406.         IF (TIEG) THEN
  2407.             CALL ZMESS('      ELSEIF(IOP..EQ..44)THEN',IODINS)
  2408.         ELSE
  2409.             CALL ZMESS('      ELSEIF (IOP..EQ..'','') THEN',IODINS)
  2410.         END IF
  2411.         CALL ZMESS('      KVAL(NREQ)=LRANGE',IODINS)
  2412.         CALL ZMESS('      ELSE',IODINS)
  2413.         IF (TIEG) THEN
  2414.             CALL ZMESS('      CALL REMARK(''TRACE SYNTAX ERROR'')',
  2415.      +                  IODINS)
  2416.         ELSE
  2417.             CALL ZMESS('      WRITE (ITTRA,170)',IODINS)
  2418.         END IF
  2419.         CALL ZMESS('      NREQ=NREQ-1',IODINS)
  2420.         CALL ZMESS('      END IF',IODINS)
  2421.         CALL ZMESS('      ELSE',IODINS)
  2422.         IF (TIEG) THEN
  2423.             CALL ZMESS('      CALL REMARK(''TOO MANY TRACE REQUESTS'')'
  2424.      +                  ,IODINS)
  2425.         ELSE
  2426.             CALL ZMESS('      WRITE (ITTRA,180)',IODINS)
  2427.         END IF
  2428.         CALL ZMESS('      GOTO 120',IODINS)
  2429.         CALL ZMESS('      END IF',IODINS)
  2430.         CALL ZMESS('      ELSE',IODINS)
  2431.         IF (TIEG) THEN
  2432.             CALL ZMESS('      CALL REMARK(''TRACE SYNTAX ERROR'')',
  2433.      +                  IODINS)
  2434.         ELSE
  2435.             CALL ZMESS('      WRITE (ITTRA,170)',IODINS)
  2436.         END IF
  2437.         CALL ZMESS('      END IF',IODINS)
  2438.         CALL ZMESS('      GOTO 100',IODINS)
  2439.         IF (TIEG) THEN
  2440.             CALL ZMESS(' 110  CALL REMARK(''TRACE SYNTAX ERROR'')',
  2441.      +                  IODINS)
  2442.         ELSE
  2443.             CALL ZMESS(' 110  WRITE (ITTRA,170)',IODINS)
  2444.         END IF
  2445.         CALL ZMESS('      GOTO 100',IODINS)
  2446.         IF (TIEG) THEN
  2447.             CALL ZMESS(' 120  CALL CLOSE(INTRA)',IODINS)
  2448. C Output dummy routine to replace user's ZINIT
  2449.             CALL ZMESS('      END',IODINS)
  2450.             CALL ZMESS('      SUBROUTINE X'//VNAMEG,IODINS)
  2451.         ELSE
  2452.             CALL ZMESS(' 120  CLOSE(INTRA,ERR=121)',IODINS)
  2453.             CALL ZMESS(' 121  CONTINUE',IODINS)
  2454.             CALL ZMESS('  150 FORMAT (I4,A1,I4)',IODINS)
  2455.             CALL ZMESS('  160 FORMAT (3X,A6,I4,A1,I4)',IODINS)
  2456.             CALL ZMESS('  170 FORMAT (1X,''**TRACE REQUEST '//
  2457.      +                  'UNRECOGNIZABLE'')',IODINS)
  2458.             CALL OUTTXT('  180 FORMAT (1X,''**ONLY FIRST ',IODINS)
  2459.             CALL ZPTINT(MTREQG,1,IODINS)
  2460.             CALL ZMESS(' TRACE REQUESTS ACCEPTED'')',IODINS)
  2461.         END IF
  2462.         CALL ZMESS('      END',IODINS)
  2463.  
  2464.         END
  2465. C ----------------------------------------------------------------------
  2466. C
  2467. C       W T O U T S   -   Insert trace output routine instrumentation
  2468. C
  2469.  
  2470.         SUBROUTINE WTOUTS
  2471.  
  2472. C---------------------------------------------------------
  2473. C    TOOLPACK/1    Release: 2.3
  2474. C---------------------------------------------------------
  2475.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  2476.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  2477.  
  2478.         SAVE /IO/
  2479.  
  2480. C---------------------------------------------------------
  2481. C    TOOLPACK/1    Release: 2.3
  2482. C---------------------------------------------------------
  2483. C                  LOGICAL VARIABLES
  2484.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  2485.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  2486.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  2487.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  2488.      *         TREEG
  2489.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  2490.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  2491.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  2492.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  2493.  
  2494.         SAVE /LOGIC/
  2495.  
  2496. C---------------------------------------------------------
  2497. C    TOOLPACK/1    Release: 2.3
  2498. C---------------------------------------------------------
  2499. C Option Settings
  2500.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  2501.      +                 MTREQG,TIEG,ITRUNG
  2502.  
  2503.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  2504.      +          ITRUNG
  2505.         LOGICAL TIEG
  2506.  
  2507.         SAVE /OPTSC/
  2508.  
  2509. C---------------------------------------------------------
  2510. C    TOOLPACK/1    Release: 2.3
  2511. C---------------------------------------------------------
  2512.         COMMON/ANVNAM/VNAMEG
  2513.         CHARACTER*5 VNAMEG
  2514.         SAVE/ANVNAM/
  2515.  
  2516. *$AS$ (TRACEG)
  2517.         CALL ZMESS('      SUBROUTINE V'//VNAMEG//'(NSEG,ITITLE)',
  2518.      +              IODINS)
  2519.         CALL ZMESS('      CHARACTER*11 ITITLE',IODINS)
  2520.         CALL ZMESS('      SAVE IBUFF,LAST,NBUFF,NREP',IODINS)
  2521.         CALL ZMESS('      INTEGER IBUFF(11)',IODINS)
  2522.         CALL TCOMNS
  2523.         CALL ZMESS('      DATA LAST,NBUFF,NREP/0,0,-1/',IODINS)
  2524.         CALL ZMESS('      IF (NSEG..GT..0) THEN',IODINS)
  2525.         CALL ZMESS('      IF (NSEG..EQ..LAST..AND..NBUFF..LE..9) THEN',
  2526.      +              IODINS)
  2527.         CALL ZMESS('      IF (NREP..EQ..-1) NBUFF=NBUFF+1',IODINS)
  2528.         CALL ZMESS('      NREP=NREP-1',IODINS)
  2529.         CALL ZMESS('      IBUFF(NBUFF)=NREP',IODINS)
  2530.         CALL ZMESS('      ELSE',IODINS)
  2531.         CALL ZMESS('      LAST=NSEG',IODINS)
  2532.         CALL ZMESS('      NBUFF=NBUFF+1',IODINS)
  2533.         CALL ZMESS('      IBUFF(NBUFF)=NSEG',IODINS)
  2534.         CALL ZMESS('      NREP=-1',IODINS)
  2535.         CALL ZMESS('      END IF',IODINS)
  2536.         CALL ZMESS('      END IF',IODINS)
  2537.         CALL ZMESS('      IF (NBUFF..EQ..11..OR..(NSEG..LT..0..AND..'//
  2538.      +              'NBUFF..GT..0)) THEN',IODINS)
  2539.         IF (TIEG) THEN
  2540.             CALL ZMESS('      CALL ZCHOUT(ITITLE,ITTRA)',IODINS)
  2541.             CALL ZMESS('      DO 100 I=1,NBUFF',IODINS)
  2542.             CALL ZMESS(' 100  CALL ZPTINT(IBUFF(I),11,ITTRA)',IODINS)
  2543.             CALL ZMESS('      CALL PUTCH(10,ITTRA)',IODINS)
  2544.         ELSE
  2545.             CALL ZMESS('      WRITE (ITTRA,100) ITITLE,'//
  2546.      +                  '(IBUFF(I),I=1,NBUFF)',IODINS)
  2547.             CALL ZMESS('  100 FORMAT (1X,A11,11I6)',IODINS)
  2548.         END IF
  2549.         CALL ZMESS('      LAST=0',IODINS)
  2550.         CALL ZMESS('      NBUFF=0',IODINS)
  2551.         CALL ZMESS('      NREP=-1',IODINS)
  2552.         CALL ZMESS('      END IF',IODINS)
  2553.         CALL ZMESS('      END',IODINS)
  2554.  
  2555.         END
  2556.